substitute-binary: Implement `--substitute'.

This allows build outputs to be transparently downloaded from
http://hydra.gnu.org, for example.

* config-daemon.ac: Check for `gzip', `bzip2', and `xz'.
* guix/config.scm.in (%gzip, %bzip2, %xz): New variable.
* guix/scripts/substitute-binary.scm (fetch): Return SIZE as a second value.
  (<narinfo>): Change `url' to `uri'.
  (make-narinfo): Rename to...
  (narinfo-maker): ... this.  Handle relative URLs.
  (fetch-narinfo): Adjust accordingly.
  (filtered-port, decompressed-port): New procedures.
  (guix-substitute-binary): Implement the `--substitute' case.
* tests/store.scm ("substitute query"): Use (%store-prefix) instead
  of (getenv "NIX_STORE_DIR").
  ("substitute"): New test.

4 files changed, 154 insertions, 23 deletions

diff --git a/config-daemon.ac b/config-daemon.ac
index eed1e23f9e5..7c51f2b95c5 100644
--- a/config-daemon.ac
+++ b/config-daemon.ac
@@ -11,6 +11,14 @@ if test "x$guix_build_daemon" = "xyes"; then
   AC_PROG_RANLIB
   AC_CONFIG_HEADER([nix/config.h])
 
+  dnl Decompressors, for use by the substituter.
+  AC_PATH_PROG([GZIP], [gzip])
+  AC_PATH_PROG([BZIP2], [bzip2])
+  AC_PATH_PROG([XZ], [xz])
+  AC_SUBST([GZIP])
+  AC_SUBST([BZIP2])
+  AC_SUBST([XZ])
+
   dnl Use 64-bit file system calls so that we can support files > 2 GiB.
   AC_SYS_LARGEFILE
 
diff --git a/guix/config.scm.in b/guix/config.scm.in
index ab7b0669b85..772ea8c289c 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -26,7 +26,10 @@
             %system
             %libgcrypt
             %nixpkgs
-            %nix-instantiate))
+            %nix-instantiate
+            %gzip
+            %bzip2
+            %xz))
 
 ;;; Commentary:
 ;;;
@@ -67,4 +70,13 @@
 (define %nix-instantiate
   "@NIX_INSTANTIATE@")
 
+(define %gzip
+  "@GZIP@")
+
+(define %bzip2
+  "@BZIP2@")
+
+(define %xz
+  "@XZ@")
+
 ;;; config.scm ends here
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 64df4f09d69..2b447ce7f2b 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -20,10 +20,13 @@
   #:use-module (guix ui)
   #:use-module (guix store)
   #:use-module (guix utils)
+  #:use-module (guix config)
+  #:use-module (guix nar)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
   #:use-module (ice-9 threads)
+  #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
@@ -70,9 +73,12 @@ pairs."
     (apply make args)))
 
 (define (fetch uri)
+  "Return a binary input port to URI and the number of bytes it's expected to
+provide."
   (case (uri-scheme uri)
     ((file)
-     (open-input-file (uri-path uri)))
+     (let ((port (open-input-file (uri-path uri))))
+       (values port (stat:size (stat port)))))
     ((http)
      (let*-values (((resp port)
                     ;; XXX: `http-get*' was introduced in 2.0.7, and deprecated
@@ -86,7 +92,7 @@ pairs."
                     (response-content-length resp)))
        (case code
          ((200)                                   ; OK
-          port)
+          (values port size))
          ((301                                    ; moved permanently
            302)                                   ; found (redirection)
           (let ((uri (response-location resp)))
@@ -120,11 +126,11 @@ failure."
                           '("StoreDir" "WantMassQuery")))))
 
 (define-record-type <narinfo>
-  (%make-narinfo path url compression file-hash file-size nar-hash nar-size
+  (%make-narinfo path uri compression file-hash file-size nar-hash nar-size
                  references deriver system)
   narinfo?
   (path         narinfo-path)
-  (url          narinfo-url)
+  (uri          narinfo-uri)
   (compression  narinfo-compression)
   (file-hash    narinfo-file-hash)
   (file-size    narinfo-file-size)
@@ -134,18 +140,26 @@ failure."
   (deriver      narinfo-deriver)
   (system       narinfo-system))
 
-(define (make-narinfo path url compression file-hash file-size nar-hash nar-size
-                      references deriver system)
-  "Return a new <narinfo> object."
-  (%make-narinfo path url compression file-hash
-                 (and=> file-size string->number)
-                 nar-hash
-                 (and=> nar-size string->number)
-                 (string-tokenize references)
-                 (match deriver
-                   ((or #f "") #f)
-                   (_ deriver))
-                 system))
+(define (narinfo-maker cache-url)
+  "Return a narinfo constructor for narinfos originating from CACHE-URL."
+  (lambda (path url compression file-hash file-size nar-hash nar-size
+                references deriver system)
+    "Return a new <narinfo> object."
+    (%make-narinfo path
+
+                   ;; Handle the case where URL is a relative URL.
+                   (or (string->uri url)
+                       (string->uri (string-append cache-url "/" url)))
+
+                   compression file-hash
+                   (and=> file-size string->number)
+                   nar-hash
+                   (and=> nar-size string->number)
+                   (string-tokenize references)
+                   (match deriver
+                     ((or #f "") #f)
+                     (_ deriver))
+                   system)))
 
 (define (fetch-narinfo cache path)
   "Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH."
@@ -159,11 +173,36 @@ failure."
                                   (store-path-hash-part path)
                                   ".narinfo"))
          (lambda (properties)
-           (alist->record properties make-narinfo
+           (alist->record properties (narinfo-maker (cache-url cache))
                           '("StorePath" "URL" "Compression"
                             "FileHash" "FileSize" "NarHash" "NarSize"
                             "References" "Deriver" "System")))))
 
+(define (filtered-port command input)
+  "Return an input port (and PID) where data drained from INPUT is filtered
+through COMMAND.  INPUT must be a file input port."
+  (let ((i+o (pipe)))
+    (match (primitive-fork)
+      (0
+       (close-port (car i+o))
+       (close-port (current-input-port))
+       (dup2 (fileno input) 0)
+       (close-port (current-output-port))
+       (dup2 (fileno (cdr i+o)) 1)
+       (apply execl (car command) command))
+      (child
+       (close-port (cdr i+o))
+       (values (car i+o) child)))))
+
+(define (decompressed-port compression input)
+  "Return an input port where INPUT is decompressed according to COMPRESSION."
+  (match compression
+    ("none"  (values input #f))
+    ("bzip2" (filtered-port `(,%bzip2 "-dc") input))
+    ("xz"    (filtered-port `(,%xz "-dc") input))
+    ("gzip"  (filtered-port `(,%gzip "-dc") input))
+    (else    (error "unsupported compression scheme" compression))))
+
 (define %cache-url
   (or (getenv "GUIX_BINARY_SUBSTITUTE_URL")
       "http://hydra.gnu.org"))
@@ -222,10 +261,29 @@ failure."
                   (error "unknown `--query' command" wtf)))
                (loop (read-line)))))))
     (("--substitute" store-path destination)
-     ;; Download PATH and add it to the store.
-     ;; TODO: Implement.
-     (format (current-error-port) "substitution not implemented yet~%")
-     #f)
+     ;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
+     (let* ((cache   (open-cache %cache-url))
+            (narinfo (fetch-narinfo cache store-path))
+            (uri     (narinfo-uri narinfo)))
+       ;; Tell the daemon what the expected hash of the Nar itself is.
+       (format #t "~a~%" (narinfo-hash narinfo))
+
+       (let*-values (((raw download-size)
+                      (fetch uri))
+                     ((input pid)
+                      (decompressed-port (narinfo-compression narinfo)
+                                         raw)))
+         ;; Note that Hydra currently generates Nars on the fly and doesn't
+         ;; specify a Content-Length, so DOWNLOAD-SIZE is #f in practice.
+         (format (current-error-port)
+                 (_ "downloading `~a' from `~a'~:[~*~; (~,1f KiB)~]...~%")
+                 store-path (uri->string uri)
+                 download-size
+                 (and=> download-size (cut / <> 1024.0)))
+
+         ;; Unpack the Nar at INPUT into DESTINATION.
+         (restore-file input destination)
+         (or (not pid) (zero? (cdr (waitpid pid)))))))
     (("--version")
      (show-version-and-exit "guix substitute-binary"))))
 
diff --git a/tests/store.scm b/tests/store.scm
index c75b99c6a9e..4ee20a93522 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -23,9 +23,11 @@
   #:use-module (guix base32)
   #:use-module (guix packages)
   #:use-module (guix derivations)
+  #:use-module (guix nar)
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
   #:use-module (ice-9 match)
+  #:use-module (rnrs io ports)
   #:use-module (web uri)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
@@ -141,7 +143,7 @@
     (call-with-output-file (string-append dir "/nix-cache-info")
       (lambda (p)
         (format p "StoreDir: ~a\nWantMassQuery: 0\n"
-                (getenv "NIX_STORE_DIR"))))
+                (%store-prefix))))
     (call-with-output-file (string-append dir "/" (store-path-hash-part o)
                                           ".narinfo")
       (lambda (p)
@@ -167,6 +169,57 @@ Deriver: ~a~%"
                  (null? (substitutable-references s))
                  (equal? (substitutable-nar-size s) 1234)))))))
 
+(test-assert "substitute"
+  (let* ((s   (open-connection))
+         (c   (random-text))                      ; contents of the output
+         (d   (build-expression->derivation
+               s "substitute-me" (%current-system)
+               `(call-with-output-file %output
+                  (lambda (p)
+                    (exit 1)                      ; would actually fail
+                    (display ,c p)))
+               '()
+               #:guile-for-build
+               (package-derivation s %bootstrap-guile (%current-system))))
+         (o   (derivation-path->output-path d))
+         (dir (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
+                     (compose uri-path string->uri))))
+    ;; Create fake substituter data, to be read by `substitute-binary'.
+    (call-with-output-file (string-append dir "/nix-cache-info")
+      (lambda (p)
+        (format p "StoreDir: ~a\nWantMassQuery: 0\n"
+                (%store-prefix))))
+    (call-with-output-file (string-append dir "/example.out")
+      (lambda (p)
+        (display c p)))
+    (call-with-output-file (string-append dir "/example.nar")
+      (lambda (p)
+        (write-file (string-append dir "/example.out") p)))
+    (call-with-output-file (string-append dir "/" (store-path-hash-part o)
+                                          ".narinfo")
+      (lambda (p)
+        (format p "StorePath: ~a
+URL: ~a
+Compression: none
+NarSize: 1234
+NarHash: sha256:~a
+References: 
+System: ~a
+Deriver: ~a~%"
+                o                                   ; StorePath
+                "example.nar"                       ; relative URL
+                (call-with-input-file (string-append dir "/example.nar")
+                  (compose bytevector->nix-base32-string sha256
+                           get-bytevector-all))
+                (%current-system)                   ; System
+                (basename d))))                     ; Deriver
+
+    ;; Make sure we use `substitute-binary'.
+    (set-build-options s #:use-substitutes? #t)
+    (and (has-substitutes? s o)
+         (build-derivations s (list d))
+         (equal? c (call-with-input-file o get-string-all)))))
+
 (test-end "store")