Add preliminary binary substituter.

* guix/scripts/substitute-binary.scm: New file.
* Makefile.am (MODULES): Add it.
* nix/scripts/substitute-binary.in: New file.
* config-daemon.ac: Produce nix/scripts/substitute-binary.
* daemon.am (nodist_pkglibexec_SCRIPTS): Add
  nix/scripts/substitute-binary.
* guix/store.scm (substitutable-path-info): Use the
  `query-substitutable-path-infos' RPC.
* nix/nix-daemon/guix-daemon.cc (main): Honor `NIX_SUBSTITUTERS'.
* pre-inst-env.in: Set `NIX_SUBSTITUTERS'.
* test-env.in: Leave `NIX_SUBSTITUTERS' unchanged.  Set
  `GUIX_BINARY_SUBSTITUTE_URL, and create
  $NIX_STATE_DIR/substituter-data.
  Run `guix-daemon' within `./pre-inst-env'.
* tests/store.scm ("substitute query"): New test.

1 files changed, 232 insertions, 0 deletions

diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
new file mode 100755
index 0000000000..6e886b6c96
--- /dev/null
+++ b/guix/scripts/substitute-binary.scm
@@ -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