11 files changed, 313 insertions(+), 13 deletions(-)

M .gitignore
M Makefile.am
M config-daemon.ac
M daemon.am
A guix/scripts/substitute-binary.scm
M guix/store.scm
M nix/nix-daemon/guix-daemon.cc
A nix/scripts/substitute-binary.in
M pre-inst-env.in
M test-env.in
M tests/store.scm

@@ 72,3 72,4 @@ stamp-h[0-9]
 /doc/guix.tp
 /doc/guix.vr
 /doc/guix.vrs
+/nix/scripts/substitute-binary

@@ 31,6 31,7 @@ MODULES =					\
   guix/scripts/package.scm			\
   guix/scripts/gc.scm				\
   guix/scripts/pull.scm				\
+  guix/scripts/substitute-binary.scm		\
   guix/base32.scm				\
   guix/utils.scm				\
   guix/derivations.scm				\

@@ 93,8 93,9 @@ if test "x$guix_build_daemon" = "xyes"; then
   AC_MSG_RESULT([$GUIX_TEST_ROOT])
   AC_SUBST([GUIX_TEST_ROOT])
 
-  AC_CONFIG_FILES([nix/scripts/list-runtime-roots],
-    [chmod +x nix/scripts/list-runtime-roots])
+  AC_CONFIG_FILES([nix/scripts/list-runtime-roots
+                   nix/scripts/substitute-binary],
+    [chmod +x nix/scripts/list-runtime-roots nix/scripts/substitute-binary])
 fi
 
 AM_CONDITIONAL([BUILD_DAEMON], [test "x$guix_build_daemon" = "xyes"])

@@ 159,7 159,8 @@ nix/libstore/schema.sql.hh: nix/libstore/schema.sql
 	           (write (get-string-all in) out)))))"
 
 nodist_pkglibexec_SCRIPTS =			\
-  nix/scripts/list-runtime-roots
+  nix/scripts/list-runtime-roots		\
+  nix/scripts/substitute-binary
 
 EXTRA_DIST +=					\
   nix/sync-with-upstream			\

@@ 0,0 1,232 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts substitute-binary)
+  #:use-module (guix ui)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 threads)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:export (guix-substitute-binary))
+
+;;; Comment:
+;;;
+;;; This is the "binary substituter".  It is invoked by the daemon do check
+;;; for the existence of available "substitutes" (pre-built binaries), and to
+;;; actually use them as a substitute to building things locally.
+;;;
+;;; If possible, substitute a binary for the requested store path, using a Nix
+;;; "binary cache".  This program implements the Nix "substituter" protocol.
+;;;
+;;; Code:
+
+(define (fields->alist port)
+  "Read recutils-style record from PORT and return them as a list of key/value
+pairs."
+  (define field-rx
+    (make-regexp "^([[:graph:]]+): (.*)$"))
+
+  (let loop ((line   (read-line port))
+             (result '()))
+    (cond ((eof-object? line)
+           (reverse result))
+          ((regexp-exec field-rx line)
+           =>
+           (lambda (match)
+             (loop (read-line port)
+                   (alist-cons (match:substring match 1)
+                               (match:substring match 2)
+                               result))))
+          (else
+           (error "unmatched line" line)))))
+
+(define (alist->record alist make keys)
+  "Apply MAKE to the values associated with KEYS in ALIST."
+  (let ((args (map (cut assoc-ref alist <>) keys)))
+    (apply make args)))
+
+(define (fetch uri)
+  (case (uri-scheme uri)
+    ((file)
+     (open-input-file (uri-path uri)))
+    ((http)
+     (let*-values (((resp port)
+                    ;; XXX: `http-get*' was introduced in 2.0.7, and deprecated
+                    ;; in 2.0.8 (!).  Assume it is available here.
+                    (if (version>? "2.0.7" (version))
+                        (http-get* uri #:decode-body? #f)
+                        (http-get uri #:streaming? #t)))
+                   ((code)
+                    (response-code resp))
+                   ((size)
+                    (response-content-length resp)))
+       (case code
+         ((200)                                   ; OK
+          port)
+         ((301                                    ; moved permanently
+           302)                                   ; found (redirection)
+          (let ((uri (response-location resp)))
+            (format #t "following redirection to `~a'...~%"
+                    (uri->string uri))
+            (fetch uri)))
+         (else
+          (error "download failed" (uri->string uri)
+                 code (response-reason-phrase resp))))))))
+
+(define-record-type <cache>
+  (%make-cache url store-directory wants-mass-query?)
+  cache?
+  (url               cache-url)
+  (store-directory   cache-store-directory)
+  (wants-mass-query? cache-wants-mass-query?))
+
+(define (open-cache url)
+  "Open the binary cache at URL.  Return a <cache> object on success, or #f on
+failure."
+  (define (download-cache-info url)
+    ;; Download the `nix-cache-info' from URL, and return its contents as an
+    ;; list of key/value pairs.
+    (and=> (false-if-exception (fetch (string->uri url)))
+           fields->alist))
+
+  (and=> (download-cache-info (string-append url "/nix-cache-info"))
+         (lambda (properties)
+           (alist->record properties
+                          (cut %make-cache url <...>)
+                          '("StoreDir" "WantMassQuery")))))
+
+(define-record-type <narinfo>
+  (%make-narinfo path url compression file-hash file-size nar-hash nar-size
+                 references deriver system)
+  narinfo?
+  (path         narinfo-path)
+  (url          narinfo-url)
+  (compression  narinfo-compression)
+  (file-hash    narinfo-file-hash)
+  (file-size    narinfo-file-size)
+  (nar-hash     narinfo-hash)
+  (nar-size     narinfo-size)
+  (references   narinfo-references)
+  (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 (fetch-narinfo cache path)
+  "Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH."
+  (define (download url)
+    ;; Download the `nix-cache-info' from URL, and return its contents as an
+    ;; list of key/value pairs.
+    (and=> (false-if-exception (fetch (string->uri url)))
+           fields->alist))
+
+  (and=> (download (string-append (cache-url cache) "/"
+                                  (store-path-hash-part path)
+                                  ".narinfo"))
+         (lambda (properties)
+           (alist->record properties make-narinfo
+                          '("StorePath" "URL" "Compression"
+                            "FileHash" "FileSize" "NarHash" "NarSize"
+                            "References" "Deriver" "System")))))
+
+(define %cache-url
+  (or (getenv "GUIX_BINARY_SUBSTITUTE_URL")
+      "http://hydra.gnu.org"))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-substitute-binary . args)
+  "Implement the build daemon's substituter protocol."
+  (match args
+    (("--query")
+     (let ((cache (open-cache %cache-url)))
+       (let loop ((command (read-line)))
+         (or (eof-object? command)
+             (begin
+               (match (string-tokenize command)
+                 (("have" paths ..1)
+                  ;; Return the subset of PATHS available in CACHE.
+                  (let ((substitutable
+                         (if cache
+                             (par-map (cut fetch-narinfo cache <>)
+                                      paths)
+                             '())))
+                    (for-each (lambda (narinfo)
+                                (when narinfo
+                                  (display (narinfo-path narinfo))
+                                  (newline)))
+                              substitutable)))
+                 (("info" paths ..1)
+                  ;; Reply info about PATHS if it's in CACHE.
+                  (let ((substitutable
+                         (if cache
+                             (par-map (cut fetch-narinfo cache <>)
+                                      paths)
+                             '())))
+                    (for-each (lambda (narinfo)
+                                (format #t "~a\n~a\n~a\n"
+                                        (narinfo-path narinfo)
+                                        (or (and=> (narinfo-deriver narinfo)
+                                                   (cute string-append
+                                                         (%store-prefix) "/"
+                                                         <>))
+                                            "")
+                                        (length (narinfo-references narinfo)))
+                                (for-each (cute format #t "~a/~a~%"
+                                                (%store-prefix) <>)
+                                          (narinfo-references narinfo))
+                                (format #t "~a\n~a\n"
+                                        (or (narinfo-file-size narinfo) 0)
+                                        (or (narinfo-size narinfo) 0))
+                                (newline))
+                              substitutable)))
+                 (wtf
+                  (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)
+    (("--version")
+     (show-version-and-exit "guix substitute-binary"))))
+
+;;; substitute-binary.scm ends here

@@ 662,7 662,7 @@ file name.  Return #t on success."
              store-path-list))
 
 (define substitutable-path-info
-  (operation (query-substitutable-paths (store-path-list paths))
+  (operation (query-substitutable-path-infos (store-path-list paths))
              "Return information about the subset of PATHS that is
 substitutable.  For each substitutable path, a `substitutable?' object is
 returned."

@@ 200,9 200,17 @@ main (int argc, char *argv[])
     {
       settings.processEnvironment ();
 
-      /* FIXME: Disable substitutes until we have something that works.  */
-      settings.useSubstitutes = false;
+      /* Use our substituter by default.  */
       settings.substituters.clear ();
+      string subs = getEnv ("NIX_SUBSTITUTERS", "default");
+      if (subs == "default")
+	/* XXX: No substituters until we have something that works.  */
+	settings.substituters.clear ();
+	// settings.substituters.push_back (settings.nixLibexecDir
+	// 				 + "/guix/substitute-binary");
+      else
+	settings.substituters = tokenizeString<Strings> (subs, ":");
+
 
       argp_parse (&argp, argc, argv, 0, 0, 0);
 

@@ 0,0 1,11 @@
+#!@SHELL@
+# A shorthand for "guix substitute-binary", for use by the daemon.
+
+if test "x$GUIX_UNINSTALLED" = "x"
+then
+    prefix="@prefix@"
+    exec_prefix="@exec_prefix@"
+    exec "@bindir@/guix" substitute-binary "$@"
+else
+    exec guix substitute-binary "$@"
+fi

@@ 35,8 35,9 @@ export PATH
 # Daemon helpers.
 
 NIX_ROOT_FINDER="@abs_top_builddir@/nix/scripts/list-runtime-roots"
+NIX_SUBSTITUTERS="@abs_top_builddir@/nix/scripts/substitute-binary"
 NIX_SETUID_HELPER="@abs_top_builddir@/nix-setuid-helper"
-export NIX_ROOT_FINDER NIX_SETUID_HELPER
+export NIX_ROOT_FINDER NIX_SETUID_HELPER NIX_SUBSTITUTERS
 
 # The following variables need only be defined when compiling Guix
 # modules, but we define them to be on the safe side in case of

@@ 1,7 1,7 @@
 #!/bin/sh
 
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #


@@ 26,7 26,6 @@
 
 if [ -x "@abs_top_builddir@/guix-daemon" ]
 then
-    NIX_SUBSTITUTERS=""		# don't resort to substituters
     NIX_SETUID_HELPER="@abs_top_builddir@/nix-setuid-helper" # normally unused
     NIX_IGNORE_SYMLINK_STORE=1	# in case the store is a symlink
     NIX_STORE_DIR="@GUIX_TEST_ROOT@/store"


@@ 39,18 38,24 @@ then
     # that the directory name must be chosen so that the socket's file
     # name is less than 108-char long (the size of `sun_path' in glibc).
     # Currently, in Nix builds, we're at ~106 chars...
-    NIX_STATE_DIR="@GUIX_TEST_ROOT@/var/$$" # allow for parallel tests
+    NIX_STATE_DIR="@GUIX_TEST_ROOT@/var/$$"
 
-    export NIX_SUBSTITUTERS NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR	\
+    # A place to store data of the substituter.
+    GUIX_BINARY_SUBSTITUTE_URL="file://$NIX_STATE_DIR/substituter-data"
+    rm -rf "$NIX_STATE_DIR/substituter-data"
+    mkdir -p "$NIX_STATE_DIR/substituter-data"
+
+    export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR			\
 	NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR		\
-	NIX_ROOT_FINDER NIX_SETUID_HELPER
+	NIX_ROOT_FINDER NIX_SETUID_HELPER GUIX_BINARY_SUBSTITUTE_URL
 
     # Do that because store.scm calls `canonicalize-path' on it.
     mkdir -p "$NIX_STORE_DIR"
 
     # Launch the daemon without chroot support because is may be
     # unavailable, for instance if we're not running as root.
-    "@abs_top_builddir@/guix-daemon" --disable-chroot &
+    "@abs_top_builddir@/pre-inst-env"				\
+	"@abs_top_builddir@/guix-daemon" --disable-chroot &
 
     daemon_pid=$!
     trap "kill $daemon_pid ; rm -rf $NIX_STATE_DIR" EXIT

@@ 26,6 26,7 @@
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
   #:use-module (ice-9 match)
+  #:use-module (web uri)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-64))


@@ 128,6 129,44 @@
          (null? (substitutable-paths s o))
          (null? (substitutable-path-info s o)))))
 
+(test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
+
+(test-assert "substitute query"
+  (let* ((s   (open-connection))
+         (d   (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"
+                (getenv "NIX_STORE_DIR"))))
+    (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
+References: 
+System: ~a
+Deriver: ~a~%"
+                o                                   ; StorePath
+                (string-append dir "/example.nar")  ; URL
+                (%current-system)                   ; System
+                (basename d))))                     ; Deriver
+
+    ;; Make sure `substitute-binary' correctly communicates the above data.
+    (set-build-options s #:use-substitutes? #t)
+    (and (has-substitutes? s o)
+         (equal? (list o) (substitutable-paths s (list o)))
+         (match (pk 'spi (substitutable-path-info s (list o)))
+           (((? substitutable? s))
+            (and (equal? (substitutable-deriver s) d)
+                 (null? (substitutable-references s))
+                 (equal? (substitutable-nar-size s) 1234)))))))
+
 (test-end "store")