;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 vlist)
#:use-module (guix store)
#:use-module (guix utils)
+ #:use-module (guix base16)
+ #:use-module (guix memoization)
#:use-module (guix combinators)
+ #:use-module (guix deprecation)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
#:use-module (guix monads)
- #:use-module (guix hash)
+ #:use-module (gcrypt hash)
#:use-module (guix base32)
#:use-module (guix records)
#:use-module (guix sets)
derivation-builder-environment-vars
derivation-file-name
derivation-prerequisites
- derivation-prerequisites-to-build
+ derivation-build-plan
+ derivation-prerequisites-to-build ;deprecated
<derivation-output>
derivation-output?
<derivation-input>
derivation-input?
+ derivation-input
derivation-input-path
+ derivation-input-derivation
derivation-input-sub-derivations
derivation-input-output-paths
+ derivation-input-output-path
valid-derivation-input?
&derivation-error
derivation-name
derivation-output-names
fixed-output-derivation?
- fixed-output-path
offloadable-derivation?
substitutable-derivation?
substitution-oracle
derivation-hash
+ derivation-properties
read-derivation
+ read-derivation-from-file
write-derivation
derivation->output-path
derivation->output-paths
derivation-path->output-paths
derivation
raw-derivation
+ invalidate-derivation-caches!
map-derivation
;;; Error conditions.
;;;
-(define-condition-type &derivation-error &nix-error
+(define-condition-type &derivation-error &store-error
derivation-error?
(derivation derivation-error-derivation))
;;; Nix derivations, as implemented in Nix's `derivations.cc'.
;;;
-(define-record-type <derivation>
+(define-immutable-record-type <derivation>
(make-derivation outputs inputs sources system builder args env-vars
file-name)
derivation?
(env-vars derivation-builder-environment-vars) ; list of name/value pairs
(file-name derivation-file-name)) ; the .drv file name
-(define-record-type <derivation-output>
+(define-immutable-record-type <derivation-output>
(make-derivation-output path hash-algo hash recursive?)
derivation-output?
(path derivation-output-path) ; store path
(hash derivation-output-hash) ; bytevector | #f
(recursive? derivation-output-recursive?)) ; Boolean
-(define-record-type <derivation-input>
- (make-derivation-input path sub-derivations)
+(define-immutable-record-type <derivation-input>
+ (make-derivation-input drv sub-derivations)
derivation-input?
- (path derivation-input-path) ; store path
+ (drv derivation-input-derivation) ; <derivation>
(sub-derivations derivation-input-sub-derivations)) ; list of strings
+
+(define (derivation-input-path input)
+ "Return the file name of the derivation INPUT refers to."
+ (derivation-file-name (derivation-input-derivation input)))
+
+(define* (derivation-input drv #:optional
+ (outputs (derivation-output-names drv)))
+ "Return a <derivation-input> for the OUTPUTS of DRV."
+ ;; This is a public interface meant to be more convenient than
+ ;; 'make-derivation-input' and giving us more control.
+ (make-derivation-input drv outputs))
+
+(define (derivation-input-key input)
+ "Return an object for which 'equal?' and 'hash' are constant-time, and which
+can thus be used as a key for INPUT in lookup tables."
+ (cons (derivation-input-path input)
+ (derivation-input-sub-derivations input)))
+
(set-record-type-printer! <derivation>
(lambda (drv port)
(format port "#<derivation ~a => ~a ~a>"
"Return the list of output paths corresponding to INPUT, a
<derivation-input>."
(match input
- (($ <derivation-input> path sub-drvs)
- (map (cut derivation-path->output-path path <>)
+ (($ <derivation-input> drv sub-drvs)
+ (map (cut derivation->output-path drv <>)
sub-drvs))))
+(define (derivation-input-output-path input)
+ "Return the output file name of INPUT. If INPUT has more than one outputs,
+an error is raised."
+ (match input
+ (($ <derivation-input> drv (output))
+ (derivation->output-path drv output))))
+
(define (valid-derivation-input? store input)
"Return true if INPUT is valid--i.e., if all the outputs it requests are in
the store."
Nix itself keeps only one of them."
(fold (lambda (input result)
(match input
- (($ <derivation-input> path sub-drvs)
+ (($ <derivation-input> (= derivation-file-name path) sub-drvs)
;; XXX: quadratic
(match (find (match-lambda
- (($ <derivation-input> p s)
+ (($ <derivation-input> (= derivation-file-name p)
+ s)
(string=? p path)))
result)
(#f
(cons input result))
- ((and dup ($ <derivation-input> _ sub-drvs2))
+ ((and dup ($ <derivation-input> drv sub-drvs2))
;; Merge DUP with INPUT.
(let ((sub-drvs (delete-duplicates
(append sub-drvs sub-drvs2))))
- (cons (make-derivation-input path
- (sort sub-drvs string<?))
+ (cons (make-derivation-input drv (sort sub-drvs string<?))
(delq dup result))))))))
'()
inputs))
CUT? is a predicate that is passed a derivation-input and returns true to
eliminate the given input and its dependencies from the search. An example of
-search a predicate is 'valid-derivation-input?'; when it is used as CUT?, the
+such a predicate is 'valid-derivation-input?'; when it is used as CUT?, the
result is the set of prerequisites of DRV not already in valid."
(let loop ((drv drv)
(result '())
(input-set (set)))
(let ((inputs (remove (lambda (input)
- (or (set-contains? input-set input)
+ (or (set-contains? input-set
+ (derivation-input-key input))
(cut? input)))
(derivation-inputs drv))))
(fold2 loop
(append inputs result)
- (fold set-insert input-set inputs)
- (map (lambda (i)
- (call-with-input-file (derivation-input-path i)
- read-derivation))
- inputs)))))
+ (fold set-insert input-set
+ (map derivation-input-key inputs))
+ (map derivation-input-derivation inputs)))))
(define (offloadable-derivation? drv)
"Return true if DRV can be offloaded, false otherwise."
(derivation-output-path (assoc-ref outputs sub-drv)))
sub-drvs))))
-(define* (substitution-oracle store drv
+(define* (substitution-oracle store inputs-or-drv
#:key (mode (build-mode normal)))
"Return a one-argument procedure that, when passed a store file name,
-returns #t if it's substitutable and #f otherwise. The returned procedure
-knows about all substitutes for all the derivations listed in DRV, *except*
-those that are already valid (that is, it won't bother checking whether an
-item is substitutable if it's already on disk); it also knows about their
-prerequisites, unless they are themselves substitutable.
+returns a 'substitutable?' if it's substitutable and #f otherwise.
+
+The returned procedure knows about all substitutes for all the derivation
+inputs or derivations listed in INPUTS-OR-DRV, *except* those that are already
+valid (that is, it won't bother checking whether an item is substitutable if
+it's already on disk); it also knows about their prerequisites, unless they
+are themselves substitutable.
-Creating a single oracle (thus making a single 'substitutable-paths' call) and
+Creating a single oracle (thus making a single 'substitutable-path-info' call) and
reusing it is much more efficient than calling 'has-substitutes?' or similar
repeatedly, because it avoids the costs associated with launching the
substituter many times."
- (define valid?
- (cut valid-path? store <>))
-
(define valid-input?
(cut valid-derivation-input? store <>))
- (define (dependencies drv)
- ;; Skip prerequisite sub-trees of DRV whose root is valid. This allows us
- ;; to ask the substituter for just as much as needed, instead of asking it
- ;; for the whole world, which can be significantly faster when substitute
- ;; info is not already in cache.
- (append-map derivation-input-output-paths
- (derivation-prerequisites drv valid-input?)))
-
- (let* ((paths (delete-duplicates
- (concatenate
- (fold (lambda (drv result)
- (let ((self (match (derivation->output-paths drv)
- (((names . paths) ...)
- paths))))
- (cond ((eqv? mode (build-mode check))
- (cons (dependencies drv) result))
- ((every valid? self)
- result)
- (else
- (cons* self (dependencies drv) result)))))
- '()
- drv))))
- (subst (list->set (substitutable-paths store paths))))
- (cut set-contains? subst <>)))
-
-(define* (derivation-prerequisites-to-build store drv
- #:key
- (mode (build-mode normal))
- (outputs
- (derivation-output-names drv))
- (substitutable?
- (substitution-oracle store
- (list drv)
- #:mode mode)))
- "Return two values: the list of derivation-inputs required to build the
-OUTPUTS of DRV and not already available in STORE, recursively, and the list
-of required store paths that can be substituted. SUBSTITUTABLE? must be a
-one-argument procedure similar to that returned by 'substitution-oracle'."
- (define built?
- (cut valid-path? store <>))
-
- (define input-built?
- (compose (cut any built? <>) derivation-input-output-paths))
-
- (define input-substitutable?
- ;; Return true if and only if all of SUB-DRVS are subsitutable. If at
- ;; least one is missing, then everything must be rebuilt.
- (compose (cut every substitutable? <>) derivation-input-output-paths))
-
- (define (derivation-built? drv* sub-drvs)
+ (define (closure inputs)
+ (let loop ((inputs inputs)
+ (closure '())
+ (visited (set)))
+ (match inputs
+ (()
+ (reverse closure))
+ ((input rest ...)
+ (let ((key (derivation-input-key input)))
+ (cond ((set-contains? visited key)
+ (loop rest closure visited))
+ ((valid-input? input)
+ (loop rest closure (set-insert key visited)))
+ (else
+ (let ((drv (derivation-input-derivation input)))
+ (loop (append (derivation-inputs drv) rest)
+ (if (substitutable-derivation? drv)
+ (cons input closure)
+ closure)
+ (set-insert key visited))))))))))
+
+ (let* ((inputs (closure (map (match-lambda
+ ((? derivation-input? input)
+ input)
+ ((? derivation? drv)
+ (derivation-input drv)))
+ inputs-or-drv)))
+ (items (append-map derivation-input-output-paths inputs))
+ (subst (fold (lambda (subst vhash)
+ (vhash-cons (substitutable-path subst) subst
+ vhash))
+ vlist-null
+ (substitutable-path-info store items))))
+ (lambda (item)
+ (match (vhash-assoc item subst)
+ (#f #f)
+ ((key . value) value)))))
+
+(define (dependencies-of-substitutables substitutables inputs)
+ "Return the subset of INPUTS whose output file names is among the references
+of SUBSTITUTABLES."
+ (let ((items (fold set-insert (set)
+ (append-map substitutable-references substitutables))))
+ (filter (lambda (input)
+ (any (cut set-contains? items <>)
+ (derivation-input-output-paths input)))
+ inputs)))
+
+(define* (derivation-build-plan store inputs
+ #:key
+ (mode (build-mode normal))
+ (substitutable-info
+ (substitution-oracle
+ store inputs #:mode mode)))
+ "Given INPUTS, a list of derivation-inputs, return two values: the list of
+derivations to build, and the list of substitutable items that, together,
+allow INPUTS to be realized.
+
+SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned
+by 'substitution-oracle'."
+ (define (built? item)
+ (valid-path? store item))
+
+ (define (input-built? input)
;; In 'check' mode, assume that DRV is not built.
(and (not (and (eqv? mode (build-mode check))
- (eq? drv* drv)))
- (every built? (derivation-output-paths drv* sub-drvs))))
-
- (define (derivation-substitutable? drv sub-drvs)
- (and (substitutable-derivation? drv)
- (every substitutable? (derivation-output-paths drv sub-drvs))))
-
- (let loop ((drv drv)
- (sub-drvs outputs)
- (build '())
- (substitute '()))
- (cond ((derivation-built? drv sub-drvs)
- (values build substitute))
- ((derivation-substitutable? drv sub-drvs)
- (values build
- (append (derivation-output-paths drv sub-drvs)
- substitute)))
- (else
- (let ((build (if (substitutable-derivation? drv)
- build
- (cons (make-derivation-input
- (derivation-file-name drv) sub-drvs)
- build)))
- (inputs (remove (lambda (i)
- (or (member i build) ; XXX: quadratic
- (input-built? i)
- (input-substitutable? i)))
- (derivation-inputs drv))))
- (fold2 loop
- (append inputs build)
- (append (append-map (lambda (input)
- (if (and (not (input-built? input))
- (input-substitutable? input))
- (derivation-input-output-paths
- input)
- '()))
- (derivation-inputs drv))
- substitute)
- (map (lambda (i)
- (call-with-input-file (derivation-input-path i)
- read-derivation))
- inputs)
- (map derivation-input-sub-derivations inputs)))))))
-
-(define (%read-derivation drv-port)
- ;; Actually read derivation from DRV-PORT.
+ (member input inputs)))
+ (every built? (derivation-input-output-paths input))))
+
+ (define (input-substitutable-info input)
+ (and (substitutable-derivation? (derivation-input-derivation input))
+ (let* ((items (derivation-input-output-paths input))
+ (info (filter-map substitutable-info items)))
+ (and (= (length info) (length items))
+ info))))
+
+ (let loop ((inputs inputs) ;list of <derivation-input>
+ (build '()) ;list of <derivation>
+ (substitute '()) ;list of <substitutable>
+ (visited (set))) ;set of <derivation-input>
+ (match inputs
+ (()
+ (values build substitute))
+ ((input rest ...)
+ (let ((key (derivation-input-key input))
+ (deps (derivation-inputs
+ (derivation-input-derivation input))))
+ (cond ((set-contains? visited key)
+ (loop rest build substitute visited))
+ ((input-built? input)
+ (loop rest build substitute
+ (set-insert key visited)))
+ ((input-substitutable-info input)
+ =>
+ (lambda (substitutables)
+ (loop (append (dependencies-of-substitutables substitutables
+ deps)
+ rest)
+ build
+ (append substitutables substitute)
+ (set-insert key visited))))
+ (else
+ (loop (append deps rest)
+ (cons (derivation-input-derivation input) build)
+ substitute
+ (set-insert key visited)))))))))
+
+(define-deprecated (derivation-prerequisites-to-build store drv #:rest rest)
+ derivation-build-plan
+ (let-values (((build download)
+ (apply derivation-build-plan store
+ (list (derivation-input drv)) rest)))
+ (values (map derivation-input build) download)))
+
+(define* (read-derivation drv-port
+ #:optional (read-derivation-from-file
+ read-derivation-from-file))
+ "Read the derivation from DRV-PORT and return the corresponding <derivation>
+object. Call READ-DERIVATION-FROM-FILE to read derivations declared as inputs
+of the derivation being parsed.
+
+Most of the time you'll want to use 'read-derivation-from-file', which caches
+things as appropriate and is thus more efficient."
(define comma (string->symbol ","))
(fold-right (lambda (input result)
(match input
((path (sub-drvs ...))
- (cons (make-derivation-input path sub-drvs)
- result))))
+ (let ((drv (read-derivation-from-file path)))
+ (cons (make-derivation-input drv sub-drvs)
+ result)))))
'()
x))
(loop (read drv-port)
(cons (ununquote exp) result))))))
-(define read-derivation
- (let ((cache (make-weak-value-hash-table 200)))
- (lambda (drv-port)
- "Read the derivation from DRV-PORT and return the corresponding
+(define %derivation-cache
+ ;; Maps derivation file names to <derivation> objects.
+ ;; XXX: This is redundant with 'atts-cache' in the store.
+ (make-weak-value-hash-table 200))
+
+(define (read-derivation-from-file file)
+ "Read the derivation in FILE, a '.drv' file, and return the corresponding
<derivation> object."
- ;; Memoize that operation because `%read-derivation' is quite expensive,
- ;; and because the same argument is read more than 15 times on average
- ;; during something like (package-derivation s gdb).
- (let ((file (and=> (port-filename drv-port) basename)))
- (or (and file (hash-ref cache file))
- (let ((drv (%read-derivation drv-port)))
- (hash-set! cache file drv)
- drv))))))
+ ;; Memoize that operation because 'read-derivation' is quite expensive,
+ ;; and because the same argument is read more than 15 times on average
+ ;; during something like (package-derivation s gdb).
+ (or (and file (hash-ref %derivation-cache file))
+ (let ((drv (call-with-input-file file read-derivation)))
+ (hash-set! %derivation-cache file drv)
+ drv)))
(define-inlinable (write-sequence lst write-item port)
;; Write each element of LST with WRITE-ITEM to PORT, separating them with a
(define (write-input input port)
(match input
- (($ <derivation-input> path sub-drvs)
- (display "(" port)
- (write path port)
- (display "," port)
+ (($ <derivation-input> obj sub-drvs)
+ (display "(\"" port)
+
+ ;; 'derivation/masked-inputs' produces objects that contain a string
+ ;; instead of a <derivation>, so we need to account for that.
+ (display (if (derivation? obj)
+ (derivation-file-name obj)
+ obj)
+ port)
+ (display "\"," port)
(write-string-list sub-drvs)
(display ")" port))))
(write-list inputs write-input port)
(display "," port)
(write-string-list sources)
- (format port ",~s,~s," system builder)
+ (simple-format port ",\"~a\",\"~a\"," system builder)
(write-string-list args)
(display "," port)
(write-list env-vars write-env-var port)
(display ")" port))))
-(define derivation->string
- (memoize
- (lambda (drv)
- "Return the external representation of DRV as a string."
- (with-fluids ((%default-port-encoding "UTF-8"))
- (call-with-output-string
- (cut write-derivation drv <>))))))
+(define derivation->bytevector
+ (mlambda (drv)
+ "Return the external representation of DRV as a UTF-8-encoded string."
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (call-with-values open-bytevector-output-port
+ (lambda (port get-bytevector)
+ (write-derivation drv port)
+ (get-bytevector))))))
(define* (derivation->output-path drv #:optional (output "out"))
"Return the store path of its output OUTPUT. Raise a
(define derivation-path->output-path
;; This procedure is called frequently, so memoize it.
- (memoize
- (lambda* (path #:optional (output "out"))
- "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store
+ (let ((memoized (mlambda (path output)
+ (derivation->output-path (read-derivation-from-file path)
+ output))))
+ (lambda* (path #:optional (output "out"))
+ "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store
path of its output OUTPUT."
- (derivation->output-path (call-with-input-file path read-derivation)
- output))))
+ (memoized path output))))
(define (derivation-path->output-paths path)
"Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the
list of name/path pairs of its outputs."
- (derivation->output-paths (call-with-input-file path read-derivation)))
+ (derivation->output-paths (read-derivation-from-file path)))
\f
;;;
;;; Derivation primitive.
;;;
-(define (compressed-hash bv size) ; `compressHash'
- "Given the hash stored in BV, return a compressed version thereof that fits
-in SIZE bytes."
- (define new (make-bytevector size 0))
- (define old-size (bytevector-length bv))
- (let loop ((i 0))
- (if (= i old-size)
- new
- (let* ((j (modulo i size))
- (o (bytevector-u8-ref new j)))
- (bytevector-u8-set! new j
- (logxor o (bytevector-u8-ref bv i)))
- (loop (+ 1 i))))))
-
-(define derivation-path->base16-hash
- (memoize
- (lambda (file)
- "Return a string containing the base16 representation of the hash of the
-derivation at FILE."
- (call-with-input-file file
- (compose bytevector->base16-string
- derivation-hash
- read-derivation)))))
+(define derivation-base16-hash
+ (mlambdaq (drv)
+ "Return a string containing the base16 representation of the hash of DRV."
+ (bytevector->base16-string (derivation-hash drv))))
+
+(define (derivation/masked-inputs drv)
+ "Assuming DRV is a regular derivation (not fixed-output), replace the file
+name of each input with that input's hash."
+ (match drv
+ (($ <derivation> outputs inputs sources
+ system builder args env-vars)
+ (let ((inputs (map (match-lambda
+ (($ <derivation-input> drv sub-drvs)
+ (let ((hash (derivation-base16-hash drv)))
+ (make-derivation-input hash sub-drvs))))
+ inputs)))
+ (make-derivation outputs
+ (sort (delete-duplicates inputs)
+ (lambda (drv1 drv2)
+ (string<? (derivation-input-derivation drv1)
+ (derivation-input-derivation drv2))))
+ sources
+ system builder args env-vars
+ #f)))))
(define derivation-hash ; `hashDerivationModulo' in derivations.cc
- (memoize
- (lambda (drv)
+ (lambda (drv)
"Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
(match drv
(($ <derivation> ((_ . ($ <derivation-output> path
- (? symbol? hash-algo) (? bytevector? hash)
- (? boolean? recursive?)))))
+ (? symbol? hash-algo) (? bytevector? hash)
+ (? boolean? recursive?)))))
;; A fixed-output derivation.
(sha256
(string->utf8
(symbol->string hash-algo)
":" (bytevector->base16-string hash)
":" path))))
- (($ <derivation> outputs inputs sources
- system builder args env-vars)
- ;; A regular derivation: replace the path of each input with that
- ;; input's hash; return the hash of serialization of the resulting
- ;; derivation.
- (let* ((inputs (map (match-lambda
- (($ <derivation-input> path sub-drvs)
- (let ((hash (derivation-path->base16-hash path)))
- (make-derivation-input hash sub-drvs))))
- inputs))
- (drv (make-derivation outputs
- (sort (coalesce-duplicate-inputs inputs)
- derivation-input<?)
- sources
- system builder args env-vars
- #f)))
-
- ;; XXX: At this point this remains faster than `port-sha256', because
- ;; the SHA256 port's `write' method gets called for every single
- ;; character.
- (sha256
- (string->utf8 (derivation->string drv)))))))))
-
-(define (store-path type hash name) ; makeStorePath
- "Return the store path for NAME/HASH/TYPE."
- (let* ((s (string-append type ":sha256:"
- (bytevector->base16-string hash) ":"
- (%store-prefix) ":" name))
- (h (sha256 (string->utf8 s)))
- (c (compressed-hash h 20)))
- (string-append (%store-prefix) "/"
- (bytevector->nix-base32-string c) "-"
- name)))
-
-(define (output-path output hash name) ; makeOutputPath
- "Return an output path for OUTPUT (the name of the output as a string) of
-the derivation called NAME with hash HASH."
- (store-path (string-append "output:" output) hash
- (if (string=? output "out")
- name
- (string-append name "-" output))))
-
-(define* (fixed-output-path name hash
- #:key
- (output "out")
- (hash-algo 'sha256)
- (recursive? #t))
- "Return an output path for the fixed output OUTPUT defined by HASH of type
-HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for
-'add-to-store'."
- (if (and recursive? (eq? hash-algo 'sha256))
- (store-path "source" hash name)
- (let ((tag (string-append "fixed:" output ":"
- (if recursive? "r:" "")
- (symbol->string hash-algo) ":"
- (bytevector->base16-string hash) ":")))
- (store-path (string-append "output:" output)
- (sha256 (string->utf8 tag))
- name))))
+ (_
+
+ ;; XXX: At this point this remains faster than `port-sha256', because
+ ;; the SHA256 port's `write' method gets called for every single
+ ;; character.
+ (sha256 (derivation->bytevector (derivation/masked-inputs drv)))))))
+
+
+(define (warn-about-derivation-deprecation name)
+ ;; TRANSLATORS: 'derivation' must not be translated; it refers to the
+ ;; 'derivation' procedure.
+ (warning (G_ "in '~a': deprecated 'derivation' calling convention used~%")
+ name))
(define* (derivation store name builder args
#:key
(system (%current-system)) (env-vars '())
- (inputs '()) (outputs '("out"))
+ (inputs '()) (sources '())
+ (outputs '("out"))
hash hash-algo recursive?
references-graphs
allowed-references disallowed-references
leaked-env-vars local-build?
- (substitutable? #t))
+ (substitutable? #t)
+ (properties '())
+ (%deprecation-warning? #t))
"Build a derivation with the given arguments, and return the resulting
<derivation> object. When HASH and HASH-ALGO are given, a
fixed-output derivation is created---i.e., one whose result is known in
derivations where the costs of data transfers would outweigh the benefits.
When SUBSTITUTABLE? is false, declare that substitutes of the derivation's
-output should not be used."
+output should not be used.
+
+PROPERTIES must be an association list describing \"properties\" of the
+derivation. It is kept as-is, uninterpreted, in the derivation."
(define (add-output-paths drv)
;; Return DRV with an actual store path for each of its output and the
;; corresponding environment variable.
`(("impureEnvVars"
. ,(string-join leaked-env-vars)))
'())
+ ,@(match properties
+ (() '())
+ (lst `(("guix properties"
+ . ,(object->string properties)))))
,@env-vars)))
(match references-graphs
(((file . path) ...)
e
outputs)))
- (define (set-file-name drv file)
- ;; Set FILE as the 'file-name' field of DRV.
- (match drv
- (($ <derivation> outputs inputs sources system builder
- args env-vars)
- (make-derivation outputs inputs sources system builder
- args env-vars file))))
+ (define-syntax-rule (warn-deprecation name)
+ (when %deprecation-warning?
+ (warn-about-derivation-deprecation name)))
(define input->derivation-input
(match-lambda
+ ((? derivation-input? input)
+ input)
(((? derivation? drv))
- (make-derivation-input (derivation-file-name drv) '("out")))
+ (warn-deprecation name)
+ (make-derivation-input drv '("out")))
(((? derivation? drv) sub-drvs ...)
- (make-derivation-input (derivation-file-name drv) sub-drvs))
- (((? direct-store-path? input))
- (make-derivation-input input '("out")))
- (((? direct-store-path? input) sub-drvs ...)
- (make-derivation-input input sub-drvs))
- ((input . _)
- (let ((path (add-to-store store (basename input)
- #t "sha256" input)))
- (make-derivation-input path '())))))
+ (warn-deprecation name)
+ (make-derivation-input drv sub-drvs))
+ (_
+ (warn-deprecation name)
+ #f)))
+
+ (define input->source
+ (match-lambda
+ (((? string? input) . _)
+ (warn-deprecation name)
+ (if (direct-store-path? input)
+ input
+ (add-to-store store (basename input)
+ #t "sha256" input)))
+ (_ #f)))
;; Note: lists are sorted alphabetically, to conform with the behavior of
;; C++ `std::map' in Nix itself.
(make-derivation-output "" hash-algo
hash recursive?)))
(sort outputs string<?)))
+ (sources (sort (delete-duplicates
+ (append (filter-map input->source inputs)
+ sources))
+ string<?))
(inputs (sort (coalesce-duplicate-inputs
- (map input->derivation-input
- (delete-duplicates inputs)))
+ (filter-map input->derivation-input inputs))
derivation-input<?))
(env-vars (sort (env-vars-with-empty-outputs
(user+system-env-vars))
(lambda (e1 e2)
(string<? (car e1) (car e2)))))
- (drv-masked (make-derivation outputs
- (filter (compose derivation-path?
- derivation-input-path)
- inputs)
- (filter-map (lambda (i)
- (let ((p (derivation-input-path i)))
- (and (not (derivation-path? p))
- p)))
- inputs)
+ (drv-masked (make-derivation outputs inputs sources
system builder args env-vars #f))
(drv (add-output-paths drv-masked)))
- (let ((file (add-text-to-store store (string-append name ".drv")
- (derivation->string drv)
- (map derivation-input-path inputs))))
- (set-file-name drv file))))
+ (let* ((file (add-data-to-store store (string-append name ".drv")
+ (derivation->bytevector drv)
+ (append (map derivation-input-path inputs)
+ sources)))
+ (drv* (set-field drv (derivation-file-name) file)))
+ ;; Preserve pointer equality. This improves the performance of
+ ;; 'eq?'-memoization on derivations.
+ (or (hash-ref %derivation-cache file)
+ (begin
+ (hash-set! %derivation-cache file drv*)
+ drv*)))))
+
+(define (invalidate-derivation-caches!)
+ "Invalidate internal derivation caches. This is mostly useful for
+long-running processes that know what they're doing. Use with care!"
+ ;; Typically this is meant to be used by Cuirass and Hydra, which can clear
+ ;; caches when they start evaluating packages for another architecture.
+ (invalidate-memoization! derivation->bytevector)
+ (invalidate-memoization! derivation-base16-hash)
+
+ ;; FIXME: Comment out to work around <https://bugs.gnu.org/36487>.
+ ;; (hash-clear! %derivation-cache)
+ )
+
+(define derivation-properties
+ (mlambdaq (drv)
+ "Return the property alist associated with DRV."
+ (match (assoc "guix properties"
+ (derivation-builder-environment-vars drv))
+ ((_ . str) (call-with-input-string str read))
+ (#f '()))))
(define* (map-derivation store drv mapping
#:key (system (%current-system)))
(define input->output-paths
(match-lambda
- (((? derivation? drv))
- (list (derivation->output-path drv)))
- (((? derivation? drv) sub-drvs ...)
- (map (cut derivation->output-path drv <>)
- sub-drvs))
- ((file)
- (list file))))
+ ((? derivation-input? input)
+ (derivation-input-output-paths input))
+ ((? string? file)
+ (list file))))
(let ((mapping (fold (lambda (pair result)
(match pair
(define rewritten-input
;; Rewrite the given input according to MAPPING, and return an input
;; in the format used in 'derivation' calls.
- (memoize
- (lambda (input loop)
- (match input
- (($ <derivation-input> path (sub-drvs ...))
- (match (vhash-assoc path mapping)
- ((_ . (? derivation? replacement))
- (cons replacement sub-drvs))
- ((_ . replacement)
- (list replacement))
- (#f
- (let* ((drv (loop (call-with-input-file path read-derivation))))
- (cons drv sub-drvs)))))))))
+ (mlambda (input loop)
+ (match input
+ (($ <derivation-input> drv (sub-drvs ...))
+ (match (vhash-assoc (derivation-file-name drv) mapping)
+ ((_ . (? derivation? replacement))
+ (derivation-input replacement sub-drvs))
+ ((_ . (? string? source))
+ source)
+ (#f
+ (derivation-input (loop drv) sub-drvs)))))))
(let loop ((drv drv))
(let* ((inputs (map (cut rewritten-input <> loop)
. ,(substitute value initial
replacements))))
(derivation-builder-environment-vars drv))
- #:inputs (append (map list sources) inputs)
+ #:inputs (filter derivation-input? inputs)
+ #:sources (append sources (filter string? inputs))
#:outputs (derivation-output-names drv)
#:hash (match (derivation-outputs drv)
((($ <derivation-output> _ algo hash))
(define* (build-derivations store derivations
#:optional (mode (build-mode normal)))
- "Build DERIVATIONS, a list of <derivation> objects or .drv file names, using
-the specified MODE."
+ "Build DERIVATIONS, a list of <derivation> or <derivation-input> objects,
+.drv file names, or derivation/output pairs, using the specified MODE."
(build-things store (map (match-lambda
+ ((? derivation? drv)
+ (derivation-file-name drv))
+ ((? derivation-input? input)
+ (cons (derivation-input-path input)
+ (string-join
+ (derivation-input-sub-derivations input)
+ ",")))
((? string? file) file)
- ((and drv ($ <derivation>))
- (derivation-file-name drv)))
+ (((? derivation? drv) . output)
+ (cons (derivation-file-name drv)
+ output))
+ (((? string? file) . output)
+ (cons file output)))
derivations)
mode))
(define search-path*
;; A memoizing version of 'search-path' so 'imported-modules' does not end
;; up looking for the same files over and over again.
- (memoize (lambda (path file)
- "Search for FILE in PATH and memoize the result. Raise a
+ (mlambda (path file)
+ "Search for FILE in PATH and memoize the result. Raise a
'&file-search-error' condition if it could not be found."
- (or (search-path path file)
- (raise (condition
- (&file-search-error (file file)
- (path path))))))))
+ (or (search-path path file)
+ (raise (condition
+ (&file-search-error (file file)
+ (path path)))))))
(define (module->source-file-name module)
"Return the file name corresponding to MODULE, a Guile module name (a list
references-graphs
allowed-references
disallowed-references
- local-build? (substitutable? #t))
+ local-build? (substitutable? #t)
+ (properties '()))
"Return a derivation that executes Scheme expression EXP as a builder
for derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV)
tuples; when SUB-DRV is omitted, \"out\" is assumed. MODULES is a list
omitted or is #f, the value of the `%guile-for-build' fluid is used instead.
See the `derivation' procedure for the meaning of REFERENCES-GRAPHS,
-ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?."
+ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, SUBSTITUTABLE?,
+and PROPERTIES."
(define guile-drv
(or guile-for-build (%guile-for-build)))
(with-fluids ((%default-port-encoding
"UTF-8"))
(call-with-output-string
- (lambda (port)
- (write prologue port)
- (write
- `(exit
- ,(match exp
- ((_ ...)
- (remove module-form? exp))
- (_ `(,exp))))
- port))))
+ (lambda (port)
+ (write prologue port)
+ (write
+ `(exit
+ ,(match exp
+ ((_ ...)
+ (remove module-form? exp))
+ (_ `(,exp))))
+ port))))
;; The references don't really matter
;; since the builder is always used in
,@(if mod-dir `("-L" ,mod-dir) '())
,builder)
+ ;; 'build-expression->derivation' is somewhat deprecated so
+ ;; don't bother warning here.
+ #:%deprecation-warning? #f
+
#:system system
#:inputs `((,(or guile-for-build (%guile-for-build)))
#:allowed-references allowed-references
#:disallowed-references disallowed-references
#:local-build? local-build?
- #:substitutable? substitutable?)))
+ #:substitutable? substitutable?
+ #:properties properties)))
\f
;;;
HCoop / jackhill / guix / guix.git / blobdiff