diff options
| -rw-r--r-- | guix/derivations.scm | 127 | ||||
| -rw-r--r-- | guix/store.scm | 30 | ||||
| -rw-r--r-- | tests/derivations.scm | 13 |
3 files changed, 161 insertions, 9 deletions
diff --git a/guix/derivations.scm b/guix/derivations.scm index 3faffd0e61..5ad9f49c00 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -25,6 +25,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (guix store) + #:use-module (guix utils) #:export (derivation? derivation-outputs derivation-inputs @@ -46,7 +47,8 @@ derivation-hash read-derivation - write-derivation)) + write-derivation + derivation)) ;;; ;;; Nix derivations, as implemented in Nix's `derivations.cc'. @@ -174,7 +176,7 @@ that form." (list->string (map object->string sub-drvs))))) inputs)) (display "," port) - (write-list sources) + (write-list (map object->string sources)) (format port ",~s,~s," system builder) (write-list (map object->string args)) (display "," port) @@ -184,6 +186,19 @@ that form." env-vars)) (display ")" port)))) +(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-hash drv) ; `hashDerivationModulo' in derivations.cc "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector." @@ -196,13 +211,14 @@ that form." (string-append "fixed:out:" hash-algo ":" hash ":" path)))) (($ <derivation> outputs inputs sources system builder args env-vars) - ;; A regular derivation: replace that path of each input with that - ;; inputs hash; return the hash of serialization of the resulting + ;; 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 derivation-hash + (compose bytevector->base16-string + derivation-hash read-derivation)))) (make-derivation-input hash sub-drvs)))) inputs)) @@ -212,6 +228,101 @@ that form." (string->utf8 (call-with-output-string (cut write-derivation drv <>)))))))) -(define (instantiate server derivation) - #f - ) +(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* (derivation store name system builder args env-vars inputs + #:key (outputs '("out")) hash hash-algo hash-mode) + "Build a derivation with the given arguments. Return the resulting +<derivation> object and its store path. When HASH, HASH-ALGO, and HASH-MODE +are given, a fixed-output derivation is created---i.e., one whose result is +known in advance, such as a file download." + (define (add-output-paths drv) + ;; Return DRV with an actual store path for each of its output and the + ;; corresponding environment variable. + (match drv + (($ <derivation> outputs inputs sources + system builder args env-vars) + (let* ((drv-hash (derivation-hash drv)) + (outputs (map (match-lambda + ((output-name . ($ <derivation-output> + _ algo hash)) + (let ((path (output-path output-name + drv-hash name))) + (cons output-name + (make-derivation-output path algo + hash))))) + outputs))) + (make-derivation outputs inputs sources system builder args + (map (match-lambda + ((name . value) + (cons name + (or (and=> (assoc-ref outputs name) + derivation-output-path) + value)))) + env-vars)))))) + + (define (env-vars-with-empty-outputs) + ;; Return a variant of ENV-VARS where each OUTPUTS is associated with an + ;; empty string, even outputs that do not appear in ENV-VARS. + (let ((e (map (match-lambda + ((name . val) + (if (member name outputs) + (cons name "") + (cons name val)))) + env-vars))) + (fold-right (lambda (output-name env-vars) + (if (assoc output-name env-vars) + env-vars + (alist-cons output-name "" env-vars))) + '() + outputs))) + + (let* ((outputs (map (lambda (name) + ;; Return outputs with an empty path. + (cons name + (make-derivation-output "" hash-algo hash))) + outputs)) + (inputs (map (match-lambda + (((? store-path? input) . sub-drvs) + (make-derivation-input input sub-drvs)) + ((input . _) + (let ((path (add-to-store store + (basename input) + (hash-algo sha256) #t #t + input))) + (make-derivation-input path '())))) + inputs)) + (env-vars (env-vars-with-empty-outputs)) + (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) + system builder args env-vars)) + (drv (add-output-paths drv-masked))) + (add-text-to-store store (string-append name ".drv") + (call-with-output-string + (cut write-derivation drv <>)) + (map derivation-input-path + inputs)))) diff --git a/guix/store.scm b/guix/store.scm index 539aa61455..1ea4d16894 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -24,6 +24,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-39) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:export (nix-server? @@ -36,11 +37,17 @@ nix-protocol-error-message nix-protocol-error-status + hash-algo + open-connection set-build-options add-text-to-store add-to-store - build-derivations)) + build-derivations + + %store-prefix + store-path? + derivation-path?)) (define %protocol-version #x109) @@ -352,3 +359,24 @@ (define-operation (build-derivations (string-list derivations)) "Build DERIVATIONS; return #t on success." boolean) + + +;;; +;;; Store paths. +;;; + +(define %store-prefix + ;; Absolute path to the Nix store. + (make-parameter "/nix/store")) + +(define store-path? + (let ((store-path-rx + (delay (make-regexp + (string-append "^.*" (%store-prefix) "/[^-]{32}-(.+)$"))))) + (lambda (path) + "Return #t if PATH is a store path." + (not (not (regexp-exec (force store-path-rx) path)))))) + +(define (derivation-path? path) + "Return #t if PATH is a derivation path." + (and (store-path? path) (string-suffix? ".drv" path))) diff --git a/tests/derivations.scm b/tests/derivations.scm index 21ec612ee6..c3aba3f12b 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -19,10 +19,14 @@ (define-module (test-derivations) #:use-module (guix derivations) + #:use-module (guix store) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) #:use-module (rnrs io ports)) +(define %store + (false-if-exception (open-connection))) + (test-begin "derivations") (test-assert "parse & export" @@ -33,6 +37,15 @@ (and (equal? b1 b2) (equal? d1 d2)))) +(test-skip (if %store 0 1)) + +(test-assert "derivation with no inputs" + (let ((builder (add-text-to-store %store "my-builder.sh" + "#!/bin/sh\necho hello, world\n" + '()))) + (store-path? (derivation %store "foo" "x86_64-linux" builder + '() '(("HOME" . "/homeless")) '())))) + (test-end) |