From 2c6ab6ccd430550dfbc95fbdd22ae017f39e5901 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 1 Apr 2013 16:08:31 +0200 Subject: store: Add `store-path-hash-part'. * guix/store.scm (store-path-hash-part): New procedure. * tests/store.scm ("store-path-hash-part", "store-path-hash-part #f"): New tests. --- tests/store.scm | 12 ++++++++++++ 1 file changed, 12 insertions(+) (limited to 'tests/store.scm') diff --git a/tests/store.scm b/tests/store.scm index c2de99e160..d6e1aa54e3 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -48,6 +48,18 @@ (test-begin "store") +(test-equal "store-path-hash-part" + "283gqy39v3g9dxjy26rynl0zls82fmcg" + (store-path-hash-part + (string-append (%store-prefix) + "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))) + +(test-equal "store-path-hash-part #f" + #f + (store-path-hash-part + (string-append (%store-prefix) + "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))) + (test-skip (if %store 0 10)) (test-assert "dead-paths" -- cgit v1.2.3 From f65cf81a3cd15eab993e129977bca46972508b4b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 2 Apr 2013 10:44:20 +0200 Subject: 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. --- .gitignore | 1 + Makefile.am | 1 + config-daemon.ac | 5 +- daemon.am | 3 +- guix/scripts/substitute-binary.scm | 232 +++++++++++++++++++++++++++++++++++++ guix/store.scm | 2 +- nix/nix-daemon/guix-daemon.cc | 12 +- nix/scripts/substitute-binary.in | 11 ++ pre-inst-env.in | 3 +- test-env.in | 17 ++- tests/store.scm | 39 +++++++ 11 files changed, 313 insertions(+), 13 deletions(-) create mode 100755 guix/scripts/substitute-binary.scm create mode 100644 nix/scripts/substitute-binary.in (limited to 'tests/store.scm') 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 74977c5cf7..888302bd96 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 0c9bc9fb69..1d4d955a0c 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 +;;; +;;; 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 . + +(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 + (%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 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 + (%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 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 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 (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 +# Copyright © 2012, 2013 Ludovic Courtès # # 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") -- cgit v1.2.3 From fe0cff14f6c5facee4192529f5c7b7a972f185ca Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Apr 2013 17:30:27 +0200 Subject: 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. (): 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. --- config-daemon.ac | 8 +++ guix/config.scm.in | 14 +++++- guix/scripts/substitute-binary.scm | 100 +++++++++++++++++++++++++++++-------- tests/store.scm | 55 +++++++++++++++++++- 4 files changed, 154 insertions(+), 23 deletions(-) (limited to 'tests/store.scm') diff --git a/config-daemon.ac b/config-daemon.ac index eed1e23f9e..7c51f2b95c 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 ab7b0669b8..772ea8c289 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 64df4f09d6..2b447ce7f2 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 - (%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 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 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 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 c75b99c6a9..4ee20a9352 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") -- cgit v1.2.3 From eba783b7b20cbf84dfd0a04bc19e3bebbc9a30fc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 15 Apr 2013 23:42:27 +0200 Subject: substitute-binary: Add a local cache. * guix/scripts/substitute-binary.scm (%narinfo-cache-directory, %narinfo-ttl, %narinfo-negative-ttl): New variables. (with-atomic-file-output, object->fields, read-narinfo, write-narinfo, narinfo->string, string->narinfo, lookup-narinfo): New procedures. (fetch-narinfo): Adjust to use `read-narinfo'. (guix-substitute-binary): Ensure the existence of %NARINFO-CACHE-DIRECTORY. Use `lookup-narinfo' instead of `fetch-narinfo'. --- guix/scripts/substitute-binary.scm | 155 ++++++++++++++++++++++++++++++++++--- test-env.in | 6 +- tests/store.scm | 6 ++ 3 files changed, 156 insertions(+), 11 deletions(-) (limited to 'tests/store.scm') diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 2b447ce7f2..453a29a5ea 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -22,6 +22,7 @@ #:use-module (guix utils) #:use-module (guix config) #:use-module (guix nar) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) @@ -30,6 +31,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (web uri) #:use-module (web client) @@ -47,6 +49,36 @@ ;;; ;;; Code: +(define %narinfo-cache-directory + ;; A local cache of narinfos, to avoid going to the network. + (or (and=> (getenv "XDG_CACHE_HOME") + (cut string-append <> "/guix/substitute-binary")) + (string-append %state-directory "/substitute-binary/cache"))) + +(define %narinfo-ttl + ;; Number of seconds during which cached narinfo lookups are considered + ;; valid. + (* 24 3600)) + +(define %narinfo-negative-ttl + ;; Likewise, but for negative lookups---i.e., cached lookup failures. + (* 3 3600)) + +(define (with-atomic-file-output file proc) + "Call PROC with an output port for the file that is going to replace FILE. +Upon success, FILE is atomically replaced by what has been written to the +output port, and PROC's result is returned." + (let* ((template (string-append file ".XXXXXX")) + (out (mkstemp! template))) + (with-throw-handler #t + (lambda () + (let ((result (proc out))) + (close out) + (rename-file template file) + result)) + (lambda (key . args) + (false-if-exception (delete-file template)))))) + (define (fields->alist port) "Read recutils-style record from PORT and return them as a list of key/value pairs." @@ -72,6 +104,17 @@ pairs." (let ((args (map (cut assoc-ref alist <>) keys))) (apply make args))) +(define (object->fields object fields port) + "Write OBJECT (typically a record) as a series of recutils-style fields to +PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs." + (let loop ((fields fields)) + (match fields + (() + object) + (((field . get) rest ...) + (format port "~a: ~a~%" field (get object)) + (loop rest))))) + (define (fetch uri) "Return a binary input port to URI and the number of bytes it's expected to provide." @@ -161,22 +204,113 @@ failure." (_ deriver)) system))) +(define* (read-narinfo port #:optional url) + "Read a narinfo from PORT in its standard external form. If URL is true, it +must be a string used to build full URIs from relative URIs found while +reading PORT." + (alist->record (fields->alist port) + (narinfo-maker url) + '("StorePath" "URL" "Compression" + "FileHash" "FileSize" "NarHash" "NarSize" + "References" "Deriver" "System"))) + +(define (write-narinfo narinfo port) + "Write NARINFO to PORT." + (define (empty-string-if-false x) + (or x "")) + + (define (number-or-empty-string x) + (if (number? x) + (number->string x) + "")) + + (object->fields narinfo + `(("StorePath" . ,narinfo-path) + ("URL" . ,(compose uri->string narinfo-uri)) + ("Compression" . ,narinfo-compression) + ("FileHash" . ,(compose empty-string-if-false + narinfo-file-hash)) + ("FileSize" . ,(compose number-or-empty-string + narinfo-file-size)) + ("NarHash" . ,(compose empty-string-if-false + narinfo-hash)) + ("NarSize" . ,(compose number-or-empty-string + narinfo-size)) + ("References" . ,(compose string-join narinfo-references)) + ("Deriver" . ,(compose empty-string-if-false + narinfo-deriver)) + ("System" . ,narinfo-system)) + port)) + +(define (narinfo->string narinfo) + "Return the external representation of NARINFO." + (call-with-output-string (cut write-narinfo narinfo <>))) + +(define (string->narinfo str) + "Return the narinfo represented by STR." + (call-with-input-string str (cut read-narinfo <>))) + (define (fetch-narinfo cache path) "Return the 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)) + (false-if-exception (fetch (string->uri url)))) (and=> (download (string-append (cache-url cache) "/" (store-path-hash-part path) ".narinfo")) - (lambda (properties) - (alist->record properties (narinfo-maker (cache-url cache)) - '("StorePath" "URL" "Compression" - "FileHash" "FileSize" "NarHash" "NarSize" - "References" "Deriver" "System"))))) + (cute read-narinfo <> (cache-url cache)))) + +(define (lookup-narinfo cache path) + "Check locally if we have valid info about PATH, otherwise go to CACHE and +check what it has." + (define now + (current-time time-monotonic)) + + (define (->time seconds) + (make-time time-monotonic 0 seconds)) + + (define (obsolete? date ttl) + (time>? (subtract-duration now (make-time time-duration 0 ttl)) + (->time date))) + + (define cache-file + (string-append %narinfo-cache-directory "/" + (store-path-hash-part path))) + + (define (cache-entry narinfo) + `(narinfo (version 0) + (date ,(time-second now)) + (value ,(and=> narinfo narinfo->string)))) + + (let*-values (((valid? cached) + (catch 'system-error + (lambda () + (call-with-input-file cache-file + (lambda (p) + (match (read p) + (('narinfo ('version 0) ('date date) + ('value #f)) + ;; A cached negative lookup. + (if (obsolete? date %narinfo-negative-ttl) + (values #f #f) + (values #t #f))) + (('narinfo ('version 0) ('date date) + ('value value)) + ;; A cached positive lookup + (if (obsolete? date %narinfo-ttl) + (values #f #f) + (values #t (string->narinfo value)))))))) + (lambda _ + (values #f #f))))) + (if valid? + cached ; including negative caches + (let ((narinfo (fetch-narinfo cache path))) + (with-atomic-file-output cache-file + (lambda (out) + (write (cache-entry narinfo) out))) + narinfo)))) (define (filtered-port command input) "Return an input port (and PID) where data drained from INPUT is filtered @@ -214,6 +348,7 @@ through COMMAND. INPUT must be a file input port." (define (guix-substitute-binary . args) "Implement the build daemon's substituter protocol." + (mkdir-p %narinfo-cache-directory) (match args (("--query") (let ((cache (open-cache %cache-url))) @@ -225,7 +360,7 @@ through COMMAND. INPUT must be a file input port." ;; Return the subset of PATHS available in CACHE. (let ((substitutable (if cache - (par-map (cut fetch-narinfo cache <>) + (par-map (cut lookup-narinfo cache <>) paths) '()))) (for-each (lambda (narinfo) @@ -237,7 +372,7 @@ through COMMAND. INPUT must be a file input port." ;; Reply info about PATHS if it's in CACHE. (let ((substitutable (if cache - (par-map (cut fetch-narinfo cache <>) + (par-map (cut lookup-narinfo cache <>) paths) '()))) (for-each (lambda (narinfo) @@ -263,7 +398,7 @@ through COMMAND. INPUT must be a file input port." (("--substitute" store-path destination) ;; 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)) + (narinfo (lookup-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)) diff --git a/test-env.in b/test-env.in index 9a6257197c..64440fb86a 100644 --- a/test-env.in +++ b/test-env.in @@ -45,9 +45,13 @@ then rm -rf "$NIX_STATE_DIR/substituter-data" mkdir -p "$NIX_STATE_DIR/substituter-data" + # Place for the substituter's cache. + XDG_CACHE_HOME="$NIX_STATE_DIR/cache-$$" + 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 GUIX_BINARY_SUBSTITUTE_URL + NIX_ROOT_FINDER NIX_SETUID_HELPER GUIX_BINARY_SUBSTITUTE_URL \ + XDG_CACHE_HOME # Do that because store.scm calls `canonicalize-path' on it. mkdir -p "$NIX_STORE_DIR" diff --git a/tests/store.scm b/tests/store.scm index 4ee20a9352..677e39e75d 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -159,6 +159,12 @@ Deriver: ~a~%" (%current-system) ; System (basename d)))) ; Deriver + ;; Remove entry from the local cache. + (false-if-exception + (delete-file (string-append (getenv "XDG_CACHE_HOME") + "/guix/substitute-binary/" + (store-path-hash-part o)))) + ;; Make sure `substitute-binary' correctly communicates the above data. (set-build-options s #:use-substitutes? #t) (and (has-substitutes? s o) -- cgit v1.2.3