First stab at the `derivation' primitive.

* guix/store.scm (%store-prefix): New parameter.
  (store-path?, derivation-path?): New procedures.

* guix/derivations.scm (write-derivation): Pass SOURCES through
  `object->string'.
  (compressed-hash, store-path, output-path, derivation): New
  procedures.

* tests/derivations.scm (%store): New global variable.
  ("derivation with no inputs"): New test.

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)