summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-04-02 10:44:20 +0200
committerLudovic Courtès <ludo@gnu.org>2013-04-12 21:57:58 +0200
commit419fffa2e84bdcfee13572e1b346a7487926113d (patch)
tree2f072c3072184eeacf19558a1b5e8e7ff03c1b38
parent04151253e3de87059f9e1a0794a8667b49095917 (diff)
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.
-rw-r--r--.gitignore1
-rw-r--r--Makefile.am1
-rw-r--r--config-daemon.ac5
-rw-r--r--daemon.am3
-rwxr-xr-xguix/scripts/substitute-binary.scm232
-rw-r--r--guix/store.scm2
-rw-r--r--nix/nix-daemon/guix-daemon.cc12
-rw-r--r--nix/scripts/substitute-binary.in11
-rw-r--r--pre-inst-env.in3
-rw-r--r--test-env.in17
-rw-r--r--tests/store.scm39
11 files changed, 313 insertions, 13 deletions
diff --git a/.gitignore b/.gitignore
index 302e473fd8..f2b1f1cd39 100644
--- a/.gitignore
+++ b/.gitignore
@@ -72,3 +72,4 @@ stamp-h[0-9]
/doc/guix.tp
/doc/guix.vr
/doc/guix.vrs
+/nix/scripts/substitute-binary
diff --git a/Makefile.am b/Makefile.am
index 722b3b79fe..8b3057fd0b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -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 \
diff --git a/config-daemon.ac b/config-daemon.ac
index f48741dfda..eed1e23f9e 100644
--- a/config-daemon.ac
+++ b/config-daemon.ac
@@ -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"])
diff --git a/daemon.am b/daemon.am
index 4f2314b773..069700b1b6 100644
--- a/daemon.am
+++ b/daemon.am
@@ -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 \
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
diff --git a/guix/store.scm b/guix/store.scm
index 3bb2656bb6..de9785c835 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -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."
diff --git a/nix/nix-daemon/guix-daemon.cc b/nix/nix-daemon/guix-daemon.cc
index 1611840bd4..0e2f36150b 100644
--- a/nix/nix-daemon/guix-daemon.cc
+++ b/nix/nix-daemon/guix-daemon.cc
@@ -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);
diff --git a/nix/scripts/substitute-binary.in b/nix/scripts/substitute-binary.in
new file mode 100644
index 0000000000..48d7bb8ff1
--- /dev/null
+++ b/nix/scripts/substitute-binary.in
@@ -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
diff --git a/pre-inst-env.in b/pre-inst-env.in
index 4e079c8d41..5e7758cd7c 100644
--- a/pre-inst-env.in
+++ b/pre-inst-env.in
@@ -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
diff --git a/test-env.in b/test-env.in
index 491a45c7b4..9a6257197c 100644
--- a/test-env.in
+++ b/test-env.in
@@ -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
diff --git a/tests/store.scm b/tests/store.scm
index d6e1aa54e3..c75b99c6a9 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -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")