[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/07: guix: split (guix store) and (guix derivations).
|
From: |
guix-commits |
|
Subject: |
01/07: guix: split (guix store) and (guix derivations). |
|
Date: |
Fri, 24 Apr 2020 16:15:42 -0400 (EDT) |
reepca pushed a commit to branch guile-daemon
in repository guix.
commit bdc366cbdce59ddc22dfa1bc70d5c49a0b6dcf92
Author: Caleb Ristvedt <address@hidden>
AuthorDate: Mon Apr 13 13:01:25 2020 -0500
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.
---
guix/derivations.scm | 621 +++++----------------------------------------
guix/store.scm | 158 ++----------
guix/store/derivations.scm | 612 ++++++++++++++++++++++++++++++++++++++++++++
guix/store/files.scm | 176 +++++++++++++
4 files changed, 868 insertions(+), 699 deletions(-)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index f6d6f7d..657c6da 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -43,64 +43,15 @@
#:use-module (guix base32)
#:use-module (guix records)
#:use-module (guix sets)
- #:export (<derivation>
- derivation?
- derivation-outputs
- derivation-inputs
- derivation-sources
- derivation-system
- derivation-builder
- derivation-builder-arguments
- derivation-builder-environment-vars
- derivation-file-name
- derivation-prerequisites
- derivation-build-plan
- derivation-prerequisites-to-build ;deprecated
-
- <derivation-output>
- derivation-output?
- derivation-output-path
- derivation-output-hash-algo
- derivation-output-hash
- derivation-output-recursive?
-
- <derivation-input>
- derivation-input?
- derivation-input
- derivation-input-path
- derivation-input-derivation
- derivation-input-sub-derivations
- derivation-input-output-paths
- derivation-input-output-path
+ #:use-module (guix store derivations)
+ #:export (derivation-build-plan
+ derivation-prerequisites-to-build ;deprecated
valid-derivation-input?
- &derivation-error
- derivation-error?
- derivation-error-derivation
- &derivation-missing-output-error
- derivation-missing-output-error?
- derivation-missing-output
-
- derivation-name
- derivation-output-names
- fixed-output-derivation?
- offloadable-derivation?
- substitutable-derivation?
- derivation-input-fold
substitution-oracle
- derivation-hash
- derivation-properties
-
- read-derivation
- read-derivation-from-file
- write-derivation
- derivation->output-path
- derivation->output-paths
- derivation-path->output-path
- derivation-path->output-paths
+
derivation
raw-derivation
- invalidate-derivation-caches!
map-derivation
@@ -116,119 +67,66 @@
build-expression->derivation)
;; Re-export it from here for backward compatibility.
- #:re-export (%guile-for-build))
-
-;;;
-;;; Error conditions.
-;;;
-
-(define-condition-type &derivation-error &store-error
- derivation-error?
- (derivation derivation-error-derivation))
-
-(define-condition-type &derivation-missing-output-error &derivation-error
- derivation-missing-output-error?
- (output derivation-missing-output))
+ #:re-export (%guile-for-build
+
+ &derivation-error
+ derivation-error?
+ derivation-error-derivation
+
+ &derivation-missing-output-error
+ derivation-missing-output-error?
+ derivation-missing-output
+
+ <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-name
+ derivation-output-names
+ derivation-hash
+ derivation-properties
+ fixed-output-derivation?
+ offloadable-derivation?
+ substitutable-derivation?
+
+ derivation-input<?
+ derivation-input-output-path
+ derivation-input-output-paths
+ derivation-input-fold
+ derivation->output-path
+ derivation->output-paths
+ derivation-path->output-path
+ derivation-path->output-paths
+
+ derivation-prerequisites
+
+ read-derivation
+ read-derivation-from-file
+ write-derivation
+ invalidate-derivation-caches!))
-;;;
-;;; Nix derivations, as implemented in Nix's `derivations.cc'.
-;;;
-
-(define-immutable-record-type <derivation>
- (make-derivation outputs inputs sources system builder args env-vars
- file-name)
- derivation?
- (outputs derivation-outputs) ; list of name/<derivation-output> pairs
- (inputs derivation-inputs) ; list of <derivation-input>
- (sources derivation-sources) ; list of store paths
- (system derivation-system) ; string
- (builder derivation-builder) ; store path
- (args derivation-builder-arguments) ; list of strings
- (env-vars derivation-builder-environment-vars) ; list of name/value pairs
- (file-name derivation-file-name)) ; the .drv file name
-
-(define-immutable-record-type <derivation-output>
- (make-derivation-output path hash-algo hash recursive?)
- derivation-output?
- (path derivation-output-path) ; store path
- (hash-algo derivation-output-hash-algo) ; symbol | #f
- (hash derivation-output-hash) ; bytevector | #f
- (recursive? derivation-output-recursive?)) ; Boolean
-
-(define-immutable-record-type <derivation-input>
- (make-derivation-input drv sub-derivations)
- derivation-input?
- (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>"
- (derivation-file-name drv)
- (string-join
- (map (match-lambda
- ((_ . output)
- (derivation-output-path output)))
- (derivation-outputs drv)))
- (number->string (object-address drv) 16))))
-
-(define (derivation-name drv)
- "Return the base name of DRV."
- (let ((base (store-path-package-name (derivation-file-name drv))))
- (string-drop-right base 4)))
-
-(define (derivation-output-names drv)
- "Return the names of the outputs of DRV."
- (match (derivation-outputs drv)
- (((names . _) ...)
- names)))
-
-(define (fixed-output-derivation? drv)
- "Return #t if DRV is a fixed-output derivation, such as the result of a
-download with a fixed hash (aka. `fetchurl')."
- (match drv
- (($ <derivation>
- (("out" . ($ <derivation-output> _ (? symbol?) (? bytevector?)))))
- #t)
- (_ #f)))
-
-(define (derivation-input<? input1 input2)
- "Compare INPUT1 and INPUT2, two <derivation-input>."
- (string<? (derivation-input-path input1)
- (derivation-input-path input2)))
-
-(define (derivation-input-output-paths input)
- "Return the list of output paths corresponding to INPUT, a
-<derivation-input>."
- (match input
- (($ <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
@@ -236,104 +134,6 @@ the store."
(every (cut valid-path? store <>)
(derivation-input-output-paths input)))
-(define (coalesce-duplicate-inputs inputs)
- "Return a list of inputs, such that when INPUTS contains the same DRV twice,
-they are coalesced, with their sub-derivations merged. This is needed because
-Nix itself keeps only one of them."
- (define (find pred lst) ;inlinable copy of 'find'
- (let loop ((lst lst))
- (match lst
- (() #f)
- ((head . tail)
- (if (pred head) head (loop tail))))))
-
- (fold (lambda (input result)
- (match input
- (($ <derivation-input> (= derivation-file-name path) sub-drvs)
- ;; XXX: quadratic
- (match (find (match-lambda
- (($ <derivation-input> (= derivation-file-name p)
- s)
- (string=? p path)))
- result)
- (#f
- (cons input result))
- ((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 drv (sort sub-drvs string<?))
- (delq dup result))))))))
- '()
- inputs))
-
-(define* (derivation-prerequisites drv #:optional (cut? (const #f)))
- "Return the list of derivation-inputs required to build DRV, recursively.
-
-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
-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
- (derivation-input-key input))
- (cut? input)))
- (derivation-inputs drv))))
- (fold2 loop
- (append inputs result)
- (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."
- (match (assoc "preferLocalBuild"
- (derivation-builder-environment-vars drv))
- (("preferLocalBuild" . "1") #f)
- (_ #t)))
-
-(define (substitutable-derivation? drv)
- "Return #t if DRV can be substituted."
- (match (assoc "allowSubstitutes"
- (derivation-builder-environment-vars drv))
- (("allowSubstitutes" . value)
- (string=? value "1"))
- (_ #t)))
-
-(define (derivation-output-paths drv sub-drvs)
- "Return the output paths of outputs SUB-DRVS of DRV."
- (match drv
- (($ <derivation> outputs)
- (map (lambda (sub-drv)
- (derivation-output-path (assoc-ref outputs sub-drv)))
- sub-drvs))))
-
-(define* (derivation-input-fold proc seed inputs
- #:key (cut? (const #f)))
- "Perform a breadth-first traversal of INPUTS, calling PROC on each input
-with the current result, starting from SEED. Skip recursion on inputs that
-match CUT?."
- (let loop ((inputs inputs)
- (result seed)
- (visited (set)))
- (match inputs
- (()
- result)
- ((input rest ...)
- (let ((key (derivation-input-key input)))
- (cond ((set-contains? visited key)
- (loop rest result visited))
- ((cut? input)
- (loop rest result (set-insert key visited)))
- (else
- (let ((drv (derivation-input-derivation input)))
- (loop (append (derivation-inputs drv) rest)
- (proc input result)
- (set-insert key visited))))))))))
-
(define* (substitution-oracle store inputs-or-drv
#:key (mode (build-mode normal)))
"Return a one-argument procedure that, when passed a store file name,
@@ -456,287 +256,13 @@ by 'substitution-oracle'."
(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 ","))
-
- (define (ununquote x)
- (match x
- (('unquote x) (ununquote x))
- ((x ...) (map ununquote x))
- (_ x)))
-
- (define (outputs->alist x)
- (fold-right (lambda (output result)
- (match output
- ((name path "" "")
- (alist-cons name
- (make-derivation-output path #f #f #f)
- result))
- ((name path hash-algo hash)
- ;; fixed-output
- (let* ((rec? (string-prefix? "r:" hash-algo))
- (algo (string->symbol
- (if rec?
- (string-drop hash-algo 2)
- hash-algo)))
- (hash (base16-string->bytevector hash)))
- (alist-cons name
- (make-derivation-output path algo
- hash rec?)
- result)))))
- '()
- x))
-
- (define (make-input-drvs x)
- (fold-right (lambda (input result)
- (match input
- ((path (sub-drvs ...))
- (let ((drv (read-derivation-from-file path)))
- (cons (make-derivation-input drv sub-drvs)
- result)))))
- '()
- x))
-
- ;; The contents of a derivation are typically ASCII, but choosing
- ;; UTF-8 allows us to take the fast path for Guile's `scm_getc'.
- (set-port-encoding! drv-port "UTF-8")
-
- (let loop ((exp (read drv-port))
- (result '()))
- (match exp
- ((? eof-object?)
- (let ((result (reverse result)))
- (match result
- (('Derive ((outputs ...) (input-drvs ...)
- (input-srcs ...)
- (? string? system)
- (? string? builder)
- ((? string? args) ...)
- ((var value) ...)))
- (make-derivation (outputs->alist outputs)
- (make-input-drvs input-drvs)
- input-srcs
- system builder args
- (fold-right alist-cons '() var value)
- (port-filename drv-port)))
- (_
- (error "failed to parse derivation" drv-port result)))))
- ((? (cut eq? <> comma))
- (loop (read drv-port) result))
- (_
- (loop (read drv-port)
- (cons (ununquote exp) result))))))
-
-(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).
- (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
- ;; comma.
- (match lst
- (()
- #t)
- ((prefix (... ...) last)
- (for-each (lambda (item)
- (write-item item port)
- (display "," port))
- prefix)
- (write-item last port))))
-
-(define-inlinable (write-list lst write-item port)
- ;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each
- ;; element.
- (display "[" port)
- (write-sequence lst write-item port)
- (display "]" port))
-
-(define-inlinable (write-tuple lst write-item port)
- ;; Same, but write LST as a tuple.
- (display "(" port)
- (write-sequence lst write-item port)
- (display ")" port))
-
-(define (write-derivation drv port)
- "Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of
-Eelco Dolstra's PhD dissertation for an overview of a previous version of
-that form."
-
- ;; Make sure we're using the faster implementation.
- (define format simple-format)
-
- (define (write-string-list lst)
- (write-list lst write port))
-
- (define (write-output output port)
- (match output
- ((name . ($ <derivation-output> path hash-algo hash recursive?))
- (write-tuple (list name path
- (if hash-algo
- (string-append (if recursive? "r:" "")
- (symbol->string hash-algo))
- "")
- (or (and=> hash bytevector->base16-string)
- ""))
- write
- port))))
-
- (define (write-input input port)
- (match input
- (($ <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))))
-
- (define (write-env-var env-var port)
- (match env-var
- ((name . value)
- (display "(" port)
- (write name port)
- (display "," port)
- (write value port)
- (display ")" port))))
-
- ;; Assume all the lists we are writing are already sorted.
- (match drv
- (($ <derivation> outputs inputs sources
- system builder args env-vars)
- (display "Derive(" port)
- (write-list outputs write-output port)
- (display "," port)
- (write-list inputs write-input port)
- (display "," port)
- (write-string-list sources)
- (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->bytevector
- (lambda (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
-'&derivation-missing-output-error' condition if OUTPUT is not an output of
-DRV."
- (let ((output* (assoc-ref (derivation-outputs drv) output)))
- (if output*
- (derivation-output-path output*)
- (raise (condition (&derivation-missing-output-error
- (derivation drv)
- (output output)))))))
-
-(define (derivation->output-paths drv)
- "Return the list of name/path pairs of the outputs of DRV."
- (map (match-lambda
- ((name . output)
- (cons name (derivation-output-path output))))
- (derivation-outputs drv)))
-
-(define derivation-path->output-path
- ;; This procedure is called frequently, so memoize it.
- (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."
- (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 (read-derivation-from-file path)))
+
;;;
;;; Derivation primitive.
;;;
-(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
- (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?)))))
- ;; A fixed-output derivation.
- (sha256
- (string->utf8
- (string-append "fixed:out:"
- (if recursive? "r:" "")
- (symbol->string hash-algo)
- ":" (bytevector->base16-string hash)
- ":" path))))
- (_
-
- ;; 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.
@@ -935,25 +461,6 @@ derivation. It is kept as-is, uninterpreted, in the
derivation."
(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-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)))
"Given MAPPING, a list of pairs of derivations, return a derivation based on
diff --git a/guix/store.scm b/guix/store.scm
index fb4b92e..261b700 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -20,6 +20,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix store)
+ #:use-module (guix store files)
#:use-module (guix utils)
#:use-module (guix config)
#:use-module (guix deprecation)
@@ -69,7 +70,6 @@
current-store-protocol-version ;for internal use
mcached
- &store-error store-error?
&store-connection-error store-connection-error?
store-connection-error-file
store-connection-error-code
@@ -170,19 +170,20 @@
interned-file
interned-file-tree
- %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
- log-file))
+ log-file)
+ #:re-export (&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))
(define %protocol-version #x163)
@@ -396,9 +397,6 @@
(define-deprecated/alias nix-server-socket store-connection-socket)
-(define-condition-type &store-error &error
- store-error?)
-
(define-condition-type &store-connection-error &store-error
store-connection-error?
(file store-connection-error-file)
@@ -1982,131 +1980,7 @@ connection, and return the result."
result))))
-;;;
-;;; Store paths.
-;;;
-
-(define %store-prefix
- ;; Absolute path to the Nix store.
- (make-parameter %store-directory))
-
-(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 (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))))
-
-(define (store-path? path)
- "Return #t if PATH is a store path."
- ;; This is a lightweight check, compared to using a regexp, but this has to
- ;; be fast as it's called often in `derivation', for instance.
- ;; `isStorePath' in Nix does something similar.
- (string-prefix? (%store-prefix) path))
-
-(define (direct-store-path? path)
- "Return #t if PATH is a store path, and not a sub-directory of a store path.
-This predicate is sometimes needed because files *under* a store path are not
-valid inputs."
- (and (store-path? path)
- (not (string=? path (%store-prefix)))
- (let ((len (+ 1 (string-length (%store-prefix)))))
- (not (string-index (substring path len) #\/)))))
-
-(define (direct-store-path path)
- "Return the direct store path part of PATH, stripping components after
-'/gnu/store/xxxx-foo'."
- (let ((prefix-length (+ (string-length (%store-prefix)) 35)))
- (if (> (string-length path) prefix-length)
- (let ((slash (string-index path #\/ prefix-length)))
- (if slash (string-take path slash) path))
- path)))
-
-(define (derivation-path? path)
- "Return #t if PATH is a derivation path."
- (and (store-path? path) (string-suffix? ".drv" path)))
-
-(define (store-path-base path)
- "Return the base path of a path in the store."
- (and (string-prefix? (%store-prefix) path)
- (let ((base (string-drop path (+ 1 (string-length (%store-prefix))))))
- (and (> (string-length base) 33)
- (not (string-index base #\/))
- base))))
-
-(define (store-path-package-name path)
- "Return the package name part of PATH, a file name in the store."
- (let ((base (store-path-base path)))
- (string-drop base (+ 32 1)))) ;32 hash part + 1 hyphen
-
-(define (store-path-hash-part path)
- "Return the hash part of PATH as a base32 string, or #f if PATH is not a
-syntactically valid store path."
- (let* ((base (store-path-base path))
- (hash (string-take base 32)))
- (and (string-every %nix-base32-charset hash)
- hash)))
-
-(define (derivation-log-file drv)
- "Return the build log file for DRV, a derivation file name, or #f if it
-could not be found."
- (let* ((base (basename drv))
- (log (string-append (or (getenv "GUIX_LOG_DIRECTORY")
- (string-append %localstatedir
"/log/guix"))
- "/drvs/"
- (string-take base 2) "/"
- (string-drop base 2)))
- (log.gz (string-append log ".gz"))
- (log.bz2 (string-append log ".bz2")))
- (cond ((file-exists? log.gz) log.gz)
- ((file-exists? log.bz2) log.bz2)
- ((file-exists? log) log)
- (else #f))))
-
+;; Uses VALID-DERIVERS, so can't go in (guix store files)
(define (log-file store file)
"Return the build log file for FILE, or #f if none could be found. FILE
must 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 0000000..1883969
--- /dev/null
+++ b/guix/store/derivations.scm
@@ -0,0 +1,612 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès
<address@hidden>
+;;; Copyright © 2016, 2017 Mathieu Lirzin <address@hidden>
+;;; Copyright © 2019 Caleb Ristvedt <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+
+(define-module (guix store derivations)
+ #:use-module (ice-9 match)
+ #:use-module (rnrs io ports)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (gcrypt hash)
+ #:use-module (guix base16)
+ #:use-module (guix combinators)
+ #:use-module (guix memoization)
+ #:use-module (guix sets)
+ #:use-module (guix store files)
+ #:export (&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>
+ make-derivation-output
+ derivation-output?
+ derivation-output-path
+ derivation-output-hash-algo
+ derivation-output-hash
+ derivation-output-recursive?
+ derivation-output-names
+
+ <derivation-input>
+ make-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<?
+ derivation-input-output-path
+ derivation-input-output-paths
+ derivation-output-paths
+ derivation-input-fold
+ 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!))
+
+;;;
+;;; Nix derivations, as implemented in Nix's `derivations.cc'.
+;;;
+
+(define-immutable-record-type <derivation>
+ (make-derivation outputs inputs sources system builder args env-vars
+ file-name)
+ derivation?
+ (outputs derivation-outputs) ; list of name/<derivation-output> pairs
+ (inputs derivation-inputs) ; list of <derivation-input>
+ (sources derivation-sources) ; list of store paths
+ (system derivation-system) ; string
+ (builder derivation-builder) ; store path
+ (args derivation-builder-arguments) ; list of strings
+ (env-vars derivation-builder-environment-vars) ; list of name/value pairs
+ (file-name derivation-file-name)) ; the .drv file name
+
+(define-immutable-record-type <derivation-output>
+ (make-derivation-output path hash-algo hash recursive?)
+ derivation-output?
+ (path derivation-output-path) ; store path
+ (hash-algo derivation-output-hash-algo) ; symbol | #f
+ (hash derivation-output-hash) ; bytevector | #f
+ (recursive? derivation-output-recursive?)) ; Boolean
+
+(define-immutable-record-type <derivation-input>
+ (make-derivation-input drv sub-derivations)
+ derivation-input?
+ (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>"
+ (derivation-file-name drv)
+ (string-join
+ (map (match-lambda
+ ((_ . output)
+ (derivation-output-path output)))
+ (derivation-outputs drv)))
+ (number->string (object-address drv)
+ 16))))
+
+;;;
+;;; Error conditions.
+;;;
+
+(define-condition-type &derivation-error &store-error
+ derivation-error?
+ (derivation derivation-error-derivation))
+
+(define-condition-type &derivation-missing-output-error &derivation-error
+ derivation-missing-output-error?
+ (output derivation-missing-output))
+
+
+(define (derivation-name drv)
+ "Return the base name of DRV."
+ (let ((base (store-path-package-name (derivation-file-name drv))))
+ (string-drop-right base 4)))
+
+(define (derivation-output-names drv)
+ "Return the names of the outputs of DRV."
+ (match (derivation-outputs drv)
+ (((names . _) ...)
+ names)))
+
+(define (fixed-output-derivation? drv)
+ "Return #t if DRV is a fixed-output derivation, such as the result of a
+download with a fixed hash (aka. `fetchurl')."
+ (match drv
+ (($ <derivation>
+ (("out" . ($ <derivation-output> _ (? symbol?) (? bytevector?)))))
+ #t)
+ (_ #f)))
+
+(define (derivation-input<? input1 input2)
+ "Compare INPUT1 and INPUT2, two <derivation-input>."
+ (string<? (derivation-input-path input1)
+ (derivation-input-path input2)))
+
+(define (coalesce-duplicate-inputs inputs)
+ "Return a list of inputs, such that when INPUTS contains the same DRV twice,
+they are coalesced, with their sub-derivations merged. This is needed because
+Nix itself keeps only one of them."
+ (define (find pred lst) ;inlinable copy of 'find'
+ (let loop ((lst lst))
+ (match lst
+ (() #f)
+ ((head . tail)
+ (if (pred head) head (loop tail))))))
+
+ (fold (lambda (input result)
+ (match input
+ (($ <derivation-input> (= derivation-file-name path) sub-drvs)
+ ;; XXX: quadratic
+ (match (find (match-lambda
+ (($ <derivation-input> (= derivation-file-name p)
+ s)
+ (string=? p path)))
+ result)
+ (#f
+ (cons input result))
+ ((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 drv (sort sub-drvs string<?))
+ (delq dup result))))))))
+ '()
+ inputs))
+
+(define* (derivation-prerequisites drv #:optional (cut? (const #f)))
+ "Return the list of derivation-inputs required to build DRV, recursively.
+
+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
+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
+ (derivation-input-key input))
+ (cut? input)))
+ (derivation-inputs drv))))
+ (fold2 loop
+ (append inputs result)
+ (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."
+ (match (assoc "preferLocalBuild"
+ (derivation-builder-environment-vars drv))
+ (("preferLocalBuild" . "1") #f)
+ (_ #t)))
+
+(define (substitutable-derivation? drv)
+ "Return #t if DRV can be substituted."
+ (match (assoc "allowSubstitutes"
+ (derivation-builder-environment-vars drv))
+ (("allowSubstitutes" . value)
+ (string=? value "1"))
+ (_ #t)))
+
+(define (derivation-output-paths drv sub-drvs)
+ "Return the output paths of outputs SUB-DRVS of DRV."
+ (match drv
+ (($ <derivation> outputs)
+ (map (lambda (sub-drv)
+ (derivation-output-path (assoc-ref outputs sub-drv)))
+ sub-drvs))))
+
+(define* (derivation-input-fold proc seed inputs
+ #:key (cut? (const #f)))
+ "Perform a breadth-first traversal of INPUTS, calling PROC on each input
+with the current result, starting from SEED. Skip recursion on inputs that
+match CUT?."
+ (let loop ((inputs inputs)
+ (result seed)
+ (visited (set)))
+ (match inputs
+ (()
+ result)
+ ((input rest ...)
+ (let ((key (derivation-input-key input)))
+ (cond ((set-contains? visited key)
+ (loop rest result visited))
+ ((cut? input)
+ (loop rest result (set-insert key visited)))
+ (else
+ (let ((drv (derivation-input-derivation input)))
+ (loop (append (derivation-inputs drv) rest)
+ (proc input result)
+ (set-insert key visited))))))))))
+
+(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 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
+ (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?)))))
+ ;; A fixed-output derivation.
+ (sha256
+ (string->utf8
+ (string-append "fixed:out:"
+ (if recursive? "r:" "")
+ (symbol->string hash-algo)
+ ":" (bytevector->base16-string hash)
+ ":" path))))
+ (_
+
+ ;; 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 (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 (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 (derivation-input-output-paths input)
+ "Return the list of output paths corresponding to INPUT, a
+<derivation-input>."
+ (match input
+ (($ <derivation-input> drv sub-drvs)
+ (map (cut derivation->output-path drv <>)
+ sub-drvs))))
+
+(define* (derivation->output-path drv #:optional (output "out"))
+ "Return the store path of its output OUTPUT. Raise a
+'&derivation-missing-output-error' condition if OUTPUT is not an output of
+DRV."
+ (let ((output* (assoc-ref (derivation-outputs drv) output)))
+ (if output*
+ (derivation-output-path output*)
+ (raise (condition (&derivation-missing-output-error
+ (derivation drv)
+ (output output)))))))
+
+(define (derivation->output-paths drv)
+ "Return the list of name/path pairs of the outputs of DRV."
+ (map (match-lambda
+ ((name . output)
+ (cons name (derivation-output-path output))))
+ (derivation-outputs drv)))
+
+(define derivation-path->output-path
+ ;; This procedure is called frequently, so memoize it.
+ (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."
+ (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 (read-derivation-from-file path)))
+
+
+(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 ","))
+
+ (define (ununquote x)
+ (match x
+ (('unquote x) (ununquote x))
+ ((x ...) (map ununquote x))
+ (_ x)))
+
+ (define (outputs->alist x)
+ (fold-right (lambda (output result)
+ (match output
+ ((name path "" "")
+ (alist-cons name
+ (make-derivation-output path #f #f #f)
+ result))
+ ((name path hash-algo hash)
+ ;; fixed-output
+ (let* ((rec? (string-prefix? "r:" hash-algo))
+ (algo (string->symbol
+ (if rec?
+ (string-drop hash-algo 2)
+ hash-algo)))
+ (hash (base16-string->bytevector hash)))
+ (alist-cons name
+ (make-derivation-output path algo
+ hash rec?)
+ result)))))
+ '()
+ x))
+
+ (define (make-input-drvs x)
+ (fold-right (lambda (input result)
+ (match input
+ ((path (sub-drvs ...))
+ (let ((drv (read-derivation-from-file path)))
+ (cons (make-derivation-input drv sub-drvs)
+ result)))))
+ '()
+ x))
+
+ ;; The contents of a derivation are typically ASCII, but choosing
+ ;; UTF-8 allows us to take the fast path for Guile's `scm_getc'.
+ (set-port-encoding! drv-port "UTF-8")
+
+ (let loop ((exp (read drv-port))
+ (result '()))
+ (match exp
+ ((? eof-object?)
+ (let ((result (reverse result)))
+ (match result
+ (('Derive ((outputs ...) (input-drvs ...)
+ (input-srcs ...)
+ (? string? system)
+ (? string? builder)
+ ((? string? args) ...)
+ ((var value) ...)))
+ (make-derivation (outputs->alist outputs)
+ (make-input-drvs input-drvs)
+ input-srcs
+ system builder args
+ (fold-right alist-cons '() var value)
+ (port-filename drv-port)))
+ (_
+ (error "failed to parse derivation" drv-port result)))))
+ ((? (cut eq? <> comma))
+ (loop (read drv-port) result))
+ (_
+ (loop (read drv-port)
+ (cons (ununquote exp) result))))))
+
+(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).
+ (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
+ ;; comma.
+ (match lst
+ (()
+ #t)
+ ((prefix (... ...) last)
+ (for-each (lambda (item)
+ (write-item item port)
+ (display "," port))
+ prefix)
+ (write-item last port))))
+
+(define-inlinable (write-list lst write-item port)
+ ;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each
+ ;; element.
+ (display "[" port)
+ (write-sequence lst write-item port)
+ (display "]" port))
+
+(define-inlinable (write-tuple lst write-item port)
+ ;; Same, but write LST as a tuple.
+ (display "(" port)
+ (write-sequence lst write-item port)
+ (display ")" port))
+
+(define (write-derivation drv port)
+ "Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of
+Eelco Dolstra's PhD dissertation for an overview of a previous version of
+that form."
+
+ ;; Make sure we're using the faster implementation.
+ (define format simple-format)
+
+ (define (write-string-list lst)
+ (write-list lst write port))
+
+ (define (write-output output port)
+ (match output
+ ((name . ($ <derivation-output> path hash-algo hash recursive?))
+ (write-tuple (list name path
+ (if hash-algo
+ (string-append (if recursive? "r:" "")
+ (symbol->string hash-algo))
+ "")
+ (or (and=> hash bytevector->base16-string)
+ ""))
+ write
+ port))))
+
+ (define (write-input input port)
+ (match input
+ (($ <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))))
+
+ (define (write-env-var env-var port)
+ (match env-var
+ ((name . value)
+ (display "(" port)
+ (write name port)
+ (display "," port)
+ (write value port)
+ (display ")" port))))
+
+ ;; Assume all the lists we are writing are already sorted.
+ (match drv
+ (($ <derivation> outputs inputs sources
+ system builder args env-vars)
+ (display "Derive(" port)
+ (write-list outputs write-output port)
+ (display "," port)
+ (write-list inputs write-input port)
+ (display "," port)
+ (write-string-list sources)
+ (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->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))))))
diff --git a/guix/store/files.scm b/guix/store/files.scm
new file mode 100644
index 0000000..84ea737
--- /dev/null
+++ b/guix/store/files.scm
@@ -0,0 +1,176 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès
<address@hidden>
+;;; Copyright © 2018 Jan Nieuwenhuizen <address@hidden>
+;;; Copyright © 2019 Caleb Ristvedt <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix store files)
+ #:use-module (ice-9 regex)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-35)
+ #:use-module (gcrypt hash)
+ #:use-module (guix base32)
+ #:use-module (guix base16)
+ #:use-module (guix config)
+ #:use-module (guix memoization)
+ #:export (&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
+ log-file
+ compressed-hash))
+
+(define-condition-type &store-error &error
+ store-error?)
+
+;;;
+;;; Store paths.
+;;;
+
+(define %store-prefix
+ ;; Absolute path to the Nix store.
+ (make-parameter %store-directory))
+
+(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 (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))))
+
+(define (store-path? path)
+ "Return #t if PATH is a store path."
+ ;; This is a lightweight check, compared to using a regexp, but this has to
+ ;; be fast as it's called often in `derivation', for instance.
+ ;; `isStorePath' in Nix does something similar.
+ (string-prefix? (%store-prefix) path))
+
+(define (direct-store-path? path)
+ "Return #t if PATH is a store path, and not a sub-directory of a store path.
+This predicate is sometimes needed because files *under* a store path are not
+valid inputs."
+ (and (store-path? path)
+ (not (string=? path (%store-prefix)))
+ (let ((len (+ 1 (string-length (%store-prefix)))))
+ (not (string-index (substring path len) #\/)))))
+
+(define (direct-store-path path)
+ "Return the direct store path part of PATH, stripping components after
+'/gnu/store/xxxx-foo'."
+ (let ((prefix-length (+ (string-length (%store-prefix)) 35)))
+ (if (> (string-length path) prefix-length)
+ (let ((slash (string-index path #\/ prefix-length)))
+ (if slash (string-take path slash) path))
+ path)))
+
+(define (derivation-path? path)
+ "Return #t if PATH is a derivation path."
+ (and (store-path? path) (string-suffix? ".drv" path)))
+
+(define (store-path-base path)
+ "Return the base path of a path in the store."
+ (and (string-prefix? (%store-prefix) path)
+ (let ((base (string-drop path (+ 1 (string-length (%store-prefix))))))
+ (and (> (string-length base) 33)
+ (not (string-index base #\/))
+ base))))
+
+(define (store-path-package-name path)
+ "Return the package name part of PATH, a file name in the store."
+ (let ((base (store-path-base path)))
+ (string-drop base (+ 32 1)))) ;32 hash part + 1 hyphen
+
+(define (store-path-hash-part path)
+ "Return the hash part of PATH as a base32 string, or #f if PATH is not a
+syntactically valid store path."
+ (let* ((base (store-path-base path))
+ (hash (string-take base 32)))
+ (and (string-every %nix-base32-charset hash)
+ hash)))
+
+(define (derivation-log-file drv)
+ "Return the build log file for DRV, a derivation file name, or #f if it
+could not be found."
+ (let* ((base (basename drv))
+ (log (string-append (or (getenv "GUIX_LOG_DIRECTORY")
+ (string-append %localstatedir
"/log/guix"))
+ "/drvs/"
+ (string-take base 2) "/"
+ (string-drop base 2)))
+ (log.gz (string-append log ".gz"))
+ (log.bz2 (string-append log ".bz2")))
+ (cond ((file-exists? log.gz) log.gz)
+ ((file-exists? log.bz2) log.bz2)
+ ((file-exists? log) log)
+ (else #f))))
+
+
- branch guile-daemon created (now 6c1ff3f), guix-commits, 2020/04/24
- 01/07: guix: split (guix store) and (guix derivations).,
guix-commits <=
- 02/07: guix: store: Register derivation outputs., guix-commits, 2020/04/24
- 06/07: guix/store/environment.scm: new module, guix-commits, 2020/04/24
- 04/07: syscalls: add missing pieces for derivation build environment, guix-commits, 2020/04/24
- 03/07: gnu: linux-container: Make it more suitable for derivation-building., guix-commits, 2020/04/24
- 07/07: guix/store/build-derivations.scm: new module., guix-commits, 2020/04/24
- 05/07: config: add variables for more directories, %impersonate-linux-2.6?, guix-commits, 2020/04/24