diff options
| -rw-r--r-- | guix/derivations.scm | 78 | ||||
| -rw-r--r-- | guix/utils.scm | 46 | ||||
| -rw-r--r-- | tests/derivations.scm | 31 |
3 files changed, 125 insertions, 30 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm index 151bff7215..09f58f0fb8 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -48,6 +48,7 @@ read-derivation write-derivation + derivation-path->output-path derivation)) ;;; @@ -186,6 +187,18 @@ that form." env-vars)) (display ")" port)))) +(define* (derivation-path->output-path path #:optional (output "out")) + "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store +path of its output OUTPUT." + (let* ((drv (call-with-input-file path read-derivation)) + (outputs (derivation-outputs drv))) + (and=> (assoc-ref outputs output) derivation-output-path))) + + +;;; +;;; Derivation primitive. +;;; + (define (compressed-hash bv size) ; `compressHash' "Given the hash stored in BV, return a compressed version thereof that fits in SIZE bytes." @@ -200,33 +213,41 @@ in SIZE bytes." (logxor o (bytevector-u8-ref bv i))) (loop (+ 1 i)))))) -(define (derivation-hash drv) ; `hashDerivationModulo' in derivations.cc - "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector." - (match drv - (($ <derivation> ((_ . ($ <derivation-output> path - (? symbol? hash-algo) (? string? hash))))) - ;; A fixed-output derivation. - (sha256 - (string->utf8 - (string-append "fixed:out:" hash-algo ":" 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 (call-with-input-file path - (compose bytevector->base16-string - derivation-hash - read-derivation)))) - (make-derivation-input hash sub-drvs)))) - inputs)) - (drv (make-derivation outputs inputs sources - system builder args env-vars))) +(define derivation-hash ; `hashDerivationModulo' in derivations.cc + (memoize + (lambda (drv) + "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector." + (match drv + (($ <derivation> ((_ . ($ <derivation-output> path + (? symbol? hash-algo) (? string? hash))))) + ;; A fixed-output derivation. (sha256 - (string->utf8 (call-with-output-string - (cut write-derivation drv <>)))))))) + (string->utf8 + (string-append "fixed:out:" (symbol->string hash-algo) + ":" 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. Note: inputs are sorted as in the order of their hex + ;; hash representation because that's what the C++ `std::map' code + ;; does. + (let* ((inputs (sort (map (match-lambda + (($ <derivation-input> path sub-drvs) + (let ((hash (call-with-input-file path + (compose bytevector->base16-string + derivation-hash + read-derivation)))) + (make-derivation-input hash sub-drvs)))) + inputs) + (lambda (i1 i2) + (string<? (derivation-input-path i1) + (derivation-input-path i2))))) + (drv (make-derivation outputs inputs sources + system builder args env-vars))) + (sha256 + (string->utf8 (call-with-output-string + (cut write-derivation drv <>)))))))))) (define (store-path type hash name) ; makeStorePath "Return the store path for NAME/HASH/TYPE." @@ -300,7 +321,9 @@ known in advance, such as a file download." (make-derivation-output "" hash-algo hash))) outputs)) (inputs (map (match-lambda - (((? store-path? input) . sub-drvs) + (((? store-path? input)) + (make-derivation-input input '("out"))) + (((? store-path? input) sub-drvs ...) (make-derivation-input input sub-drvs)) ((input . _) (let ((path (add-to-store store @@ -321,6 +344,7 @@ known in advance, such as a file download." inputs) system builder args env-vars)) (drv (add-output-paths drv-masked))) + (values (add-text-to-store store (string-append name ".drv") (call-with-output-string (cut write-derivation drv <>)) diff --git a/guix/utils.scm b/guix/utils.scm index a5f64f97a9..2ffecbfab9 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -19,9 +19,12 @@ (define-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-39) #:use-module (srfi srfi-60) #:use-module (rnrs bytevectors) #:use-module (ice-9 format) + #:autoload (ice-9 popen) (open-pipe*) + #:autoload (ice-9 rdelim) (read-line) #:use-module ((chop hash) #:select (bytevector-hash hash-method/sha256)) @@ -29,7 +32,12 @@ bytevector->base32-string bytevector->nix-base32-string bytevector->base16-string - sha256)) + sha256 + + %nixpkgs-directory + nixpkgs-derivation + + memoize)) ;;; @@ -198,3 +206,39 @@ the previous application or INIT." "Return the SHA256 of BV as a bytevector." (bytevector-hash hash-method/sha256 bv)) + + +;;; +;;; Nixpkgs. +;;; + +(define %nixpkgs-directory + (make-parameter (getenv "NIXPKGS"))) + +(define (nixpkgs-derivation attribute) + "Return the derivation path of ATTRIBUTE in Nixpkgs." + (let* ((p (open-pipe* OPEN_READ "nix-instantiate" "-A" + attribute (%nixpkgs-directory))) + (l (read-line p)) + (s (close-pipe p))) + (and (zero? (status:exit-val s)) + (not (eof-object? l)) + l))) + + +;;; +;;; Miscellaneous. +;;; + +(define (memoize proc) + "Return a memoizing version of PROC." + (let ((cache (make-hash-table))) + (lambda args + (let ((results (hash-ref cache args))) + (if results + (apply values results) + (let ((results (call-with-values (lambda () + (apply proc args)) + list))) + (hash-set! cache args results) + (apply values results))))))) diff --git a/tests/derivations.scm b/tests/derivations.scm index 64bc678828..f2a3bb2d55 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -20,6 +20,7 @@ (define-module (test-derivations) #:use-module (guix derivations) #:use-module (guix store) + #:use-module (guix utils) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) @@ -40,7 +41,7 @@ (and (equal? b1 b2) (equal? d1 d2)))) -(test-skip (if %store 0 2)) +(test-skip (if %store 0 3)) (test-assert "derivation with no inputs" (let ((builder (add-text-to-store %store "my-builder.sh" @@ -52,7 +53,7 @@ (test-assert "build derivation with 1 source" (let*-values (((builder) (add-text-to-store %store "my-builder.sh" - "#!/bin/sh\necho hello, world > \"$out\"\n" + "echo hello, world > \"$out\"\n" '())) ((drv-path drv) (derivation %store "foo" "x86_64-linux" @@ -67,6 +68,32 @@ (string=? (call-with-input-file path read-line) "hello, world"))))) + +(define %coreutils + (false-if-exception (nixpkgs-derivation "coreutils"))) + +(test-skip (if %coreutils 0 1)) + +(test-assert "build derivation with coreutils" + (let* ((builder + (add-text-to-store %store "build-with-coreutils.sh" + "echo $PATH ; mkdir --version ; mkdir $out ; touch $out/good" + '())) + (drv-path + (derivation %store "foo" "x86_64-linux" + "/bin/sh" `(,builder) + `(("PATH" . + ,(string-append + (derivation-path->output-path %coreutils) + "/bin"))) + `((,builder) + (,%coreutils)))) + (succeeded? + (build-derivations %store (list drv-path)))) + (and succeeded? + (let ((p (derivation-path->output-path drv-path))) + (file-exists? (string-append p "/good")))))) + (test-end) |