aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/derivations.scm127
-rw-r--r--guix/store.scm30
-rw-r--r--tests/derivations.scm13
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)