ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Add preliminary binary substituter.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2013-04-02 10:44:20 +02:00
parent cf53ecf514
commit f65cf81a3c
11 changed files with 313 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

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

1
Makefile.am
View file

@ -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 \

5
config-daemon.ac
View file

@ -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"])

3
daemon.am
View file

@ -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 \

232
guix/scripts/substitute-binary.scm Executable file
View file

@ -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

2
guix/store.scm
View file

@ -662,7 +662,7 @@ (define substitutable-paths
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."

12
nix/nix-daemon/guix-daemon.cc
View file

@ -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);

11
nix/scripts/substitute-binary.in Normal file
View file

@ -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

3
pre-inst-env.in
View file

@ -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

15
test-env.in
View file

@ -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,17 +38,23 @@ 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@/pre-inst-env" \
"@abs_top_builddir@/guix-daemon" --disable-chroot &
daemon_pid=$!

39
tests/store.scm
View file

@ -26,6 +26,7 @@ (define-module (test-store)
#: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 @@ (define (random-text)
(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")