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') 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 1.4.1 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') 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 1.4.1 From 53c63ee93790e4e4054bf6547199d3490b78bf47 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Apr 2013 22:54:08 +0200 Subject: nar: Implement restoration from Nar. * guix/nar.scm (&nar-error, &nar-read-error): New condition types. (dump): New procedure. (write-contents)[dump]: Remove. Use the one above instead. (read-contents, write-file, restore-file): New procedures. (%archive-version-1): New variable. --- Makefile.am | 1 + guix/nar.scm | 150 +++++++++++++++++++++++++++++++++++++++++++++++++++------- tests/nar.scm | 95 +++++++++++++++++++++++++++++++++++++ 3 files changed, 228 insertions(+), 18 deletions(-) create mode 100644 tests/nar.scm (limited to 'tests') diff --git a/Makefile.am b/Makefile.am index a8bd2f8daf..930ea6ce72 100644 --- a/Makefile.am +++ b/Makefile.am @@ -296,6 +296,7 @@ TESTS = \ tests/packages.scm \ tests/snix.scm \ tests/store.scm \ + tests/nar.scm \ tests/union.scm \ tests/guix-build.sh \ tests/guix-download.sh \ diff --git a/guix/nar.scm b/guix/nar.scm index b42f03c514..9ae76ff2a9 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -19,12 +19,23 @@ (define-module (guix nar) #:use-module (guix utils) #:use-module (guix serialization) + #:use-module ((guix build utils) #:select (with-directory-excursion)) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (ice-9 ftw) - #:export (write-file)) + #:use-module (ice-9 match) + #:export (nar-error? + nar-read-error? + nar-read-error-file + nar-read-error-port + nar-read-error-token + + write-file + restore-file)) ;;; Comment: ;;; @@ -32,6 +43,31 @@ ;;; ;;; Code: +(define-condition-type &nar-error &error ; XXX: inherit from &nix-error ? + nar-error?) + +(define-condition-type &nar-read-error &nar-error + nar-read-error? + (port nar-read-error-port) ; port from which we read + (file nar-read-error-file) ; file we were restoring, or #f + (token nar-read-error-token)) ; faulty token, or #f + + +(define (dump in out size) + "Copy SIZE bytes from IN to OUT." + (define buf-size 65536) + (define buf (make-bytevector buf-size)) + + (let loop ((left size)) + (if (<= left 0) + 0 + (let ((read (get-bytevector-n! in buf 0 (min left buf-size)))) + (if (eof-object? read) + left + (begin + (put-bytevector out buf 0 read) + (loop (- left read)))))))) + (define (write-contents file p size) "Write SIZE bytes from FILE to output port P." (define (call-with-binary-input-file file proc) @@ -45,33 +81,55 @@ (close-port port) (apply throw args)))))) - (define (dump in size) - (define buf-size 65536) - (define buf (make-bytevector buf-size)) - - (let loop ((left size)) - (if (<= left 0) - 0 - (let ((read (get-bytevector-n! in buf 0 buf-size))) - (if (eof-object? read) - left - (begin - (put-bytevector p buf 0 read) - (loop (- left read)))))))) - (write-string "contents" p) (write-long-long size p) (call-with-binary-input-file file ;; Use `sendfile' when available (Guile 2.0.8+). (if (compile-time-value (defined? 'sendfile)) (cut sendfile p <> size 0) - (cut dump <> size))) + (cut dump <> p size))) (write-padding size p)) +(define (read-contents in out) + "Read the contents of a file from the Nar at IN, write it to OUT, and return +the size in bytes." + (define executable? + (match (read-string in) + ("contents" + #f) + ("executable" + (match (list (read-string in) (read-string in)) + (("" "contents") #t) + (x (raise + (condition (&message + (message "unexpected executable file marker")) + (&nar-read-error (port in) + (file #f) + (token x)))))) + #t) + (x + (raise + (condition (&message (message "unsupported nar file type")) + (&nar-read-error (port in) (file #f) (token x))))))) + + (let ((size (read-long-long in))) + ;; Note: `sendfile' cannot be used here because of port buffering on IN. + (dump in out size) + + (when executable? + (chmod out #o755)) + (let ((m (modulo size 8))) + (unless (zero? m) + (get-bytevector-n in (- 8 m)))) + size)) + +(define %archive-version-1 + ;; Magic cookie for Nix archives. + "nix-archive-1") + (define (write-file file port) "Write the contents of FILE to PORT in Nar format, recursing into sub-directories of FILE as needed." - (define %archive-version-1 "nix-archive-1") (define p port) (write-string %archive-version-1 p) @@ -104,7 +162,63 @@ sub-directories of FILE as needed." (write-string ")" p))) entries))) (else - (error "ENOSYS"))) + (raise (condition (&message (message "ENOSYS")) + (&nar-error))))) (write-string ")" p)))) +(define (restore-file port file) + "Read a file (possibly a directory structure) in Nar format from PORT. +Restore it as FILE." + (let ((signature (read-string port))) + (unless (equal? signature %archive-version-1) + (raise + (condition (&message (message "invalid nar signature")) + (&nar-read-error (port port) + (token signature) + (file #f)))))) + + (let restore ((file file)) + (match (list (read-string port) (read-string port) (read-string port)) + (("(" "type" "regular") + (call-with-output-file file (cut read-contents port <>)) + (match (read-string port) + (")" #t) + (x (raise + (condition + (&message (message "invalid nar end-of-file marker")) + (&nar-read-error (port port) (file file) (token x))))))) + (("(" "type" "directory") + (let ((dir file)) + (mkdir dir) + (let loop ((prefix (read-string port))) + (match prefix + ("entry" + (match (list (read-string port) + (read-string port) (read-string port) + (read-string port)) + (("(" "name" file "node") + (restore (string-append dir "/" file)) + (match (read-string port) + (")" #t) + (x + (raise + (condition + (&message + (message "unexpected directory entry termination")) + (&nar-read-error (port port) + (file file) + (token x)))))) + (loop (read-string port))))) + (")" #t) ; done with DIR + (x + (raise + (condition + (&message (message "unexpected directory inter-entry marker")) + (&nar-read-error (port port) (file file) (token x))))))))) + (x + (raise + (condition + (&message (message "unsupported nar entry type")) + (&nar-read-error (port port) (file file) (token x)))))))) + ;;; nar.scm ends here diff --git a/tests/nar.scm b/tests/nar.scm new file mode 100644 index 0000000000..2d9bffd487 --- /dev/null +++ b/tests/nar.scm @@ -0,0 +1,95 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 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 (test-nar) + #:use-module (guix nar) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64) + #:use-module (ice-9 ftw)) + +;; Test the (guix nar) module. + +(define (rm-rf dir) + (file-system-fold (const #t) ; enter? + (lambda (file stat result) ; leaf + (delete-file file)) + (const #t) ; down + (lambda (dir stat result) ; up + (rmdir dir)) + (const #t) ; skip + (const #t) ; error + #t + dir + lstat)) + + +(test-begin "nar") + +(test-assert "write-file + restore-file" + (let* ((input (string-append (dirname (search-path %load-path "guix.scm")) + "/guix")) + (output (string-append (dirname input) + "/test-nar-" + (number->string (getpid)))) + (nar (string-append output ".nar"))) + (dynamic-wind + (lambda () #t) + (lambda () + (call-with-output-file nar + (cut write-file input <>)) + (call-with-input-file nar + (cut restore-file <> output)) + (let* ((strip (cute string-drop <> (string-length input))) + (sibling (compose (cut string-append output <>) strip)) + (file=? (lambda (a b) + (and (eq? (stat:type (lstat a)) (stat:type (lstat b))) + (case (stat:type (lstat a)) + ((regular) + (equal? + (call-with-input-file a get-bytevector-all) + (call-with-input-file b get-bytevector-all))) + ((symlink) + (string=? (readlink a) (readlink b))) + (else + (error "what?" (lstat a)))))))) + (file-system-fold (const #t) + (lambda (name stat result) ; leaf + (and result + (file=? name (sibling name)))) + (lambda (name stat result) ; down + result) + (lambda (name stat result) ; up + result) + (const #f) ; skip + (lambda (name stat errno result) + (pk 'error name stat errno) + #f) + (> (stat:nlink (stat output)) 2) + input + lstat))) + (lambda () + (false-if-exception (delete-file nar)) + (false-if-exception (rm-rf output)) + )))) + +(test-end "nar") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit 1.4.1 From 8f3114b7a433480c9534903d23d659ce3fb12ffb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Apr 2013 14:35:01 +0200 Subject: nar: Add support for symlinks. * guix/nar.scm (write-file): Add case for type `symlink'. (restore-file): Likewise. * tests/nar.scm (random-file-size, make-file-tree, delete-file-tree, with-file-tree, file-tree-equal?, make-random-bytevector, populate-file): New procedures. (%test-dir): New variable. ("write-file + restore-file"): Use `%test-dir' and `file-tree-equal?'. ("write-file + restore-file with symlinks"): New test. --- guix/nar.scm | 23 +++++++- tests/nar.scm | 183 +++++++++++++++++++++++++++++++++++++++++++++++----------- 2 files changed, 169 insertions(+), 37 deletions(-) (limited to 'tests') diff --git a/guix/nar.scm b/guix/nar.scm index 9ae76ff2a9..29b57dc989 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -161,6 +161,11 @@ sub-directories of FILE as needed." (dump f) (write-string ")" p))) entries))) + ((symlink) + (write-string "type" p) + (write-string "symlink" p) + (write-string "target" p) + (write-string (readlink f) p)) (else (raise (condition (&message (message "ENOSYS")) (&nar-error))))) @@ -178,14 +183,26 @@ Restore it as FILE." (file #f)))))) (let restore ((file file)) + (define (read-eof-marker) + (match (read-string port) + (")" #t) + (x (raise + (condition + (&message (message "invalid nar end-of-file marker")) + (&nar-read-error (port port) (file file) (token x))))))) + (match (list (read-string port) (read-string port) (read-string port)) (("(" "type" "regular") (call-with-output-file file (cut read-contents port <>)) - (match (read-string port) - (")" #t) + (read-eof-marker)) + (("(" "type" "symlink") + (match (list (read-string port) (read-string port)) + (("target" target) + (symlink target file) + (read-eof-marker)) (x (raise (condition - (&message (message "invalid nar end-of-file marker")) + (&message (message "invalid symlink tokens")) (&nar-read-error (port port) (file file) (token x))))))) (("(" "type" "directory") (let ((dir file)) diff --git a/tests/nar.scm b/tests/nar.scm index 2d9bffd487..4321cbda53 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -22,10 +22,122 @@ #:use-module (rnrs io ports) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) - #:use-module (ice-9 ftw)) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match)) ;; Test the (guix nar) module. + +;;; +;;; File system testing tools, initially contributed to Guile, then libchop. +;;; + +(define (random-file-size) + (define %average (* 1024 512)) ; 512 KiB + (define %stddev (* 1024 64)) ; 64 KiB + (inexact->exact + (max 0 (round (+ %average (* %stddev (random:normal))))))) + +(define (make-file-tree dir tree) + "Make file system TREE at DIR." + (let loop ((dir dir) + (tree tree)) + (define (scope file) + (string-append dir "/" file)) + + (match tree + (('directory name (body ...)) + (mkdir (scope name)) + (for-each (cute loop (scope name) <>) body)) + (('directory name (? integer? mode) (body ...)) + (mkdir (scope name)) + (for-each (cute loop (scope name) <>) body) + (chmod (scope name) mode)) + ((file) + (populate-file (scope file) (random-file-size))) + ((file (? integer? mode)) + (populate-file (scope file) (random-file-size)) + (chmod (scope file) mode)) + ((from '-> to) + (symlink to (scope from)))))) + +(define (delete-file-tree dir tree) + "Delete file TREE from DIR." + (let loop ((dir dir) + (tree tree)) + (define (scope file) + (string-append dir "/" file)) + + (match tree + (('directory name (body ...)) + (for-each (cute loop (scope name) <>) body) + (rmdir (scope name))) + (('directory name (? integer? mode) (body ...)) + (chmod (scope name) #o755) ; make sure it can be entered + (for-each (cute loop (scope name) <>) body) + (rmdir (scope name))) + ((from '-> _) + (delete-file (scope from))) + ((file _ ...) + (delete-file (scope file)))))) + +(define-syntax-rule (with-file-tree dir tree body ...) + (dynamic-wind + (lambda () + (make-file-tree dir 'tree)) + (lambda () + body ...) + (lambda () + (delete-file-tree dir 'tree)))) + +(define (file-tree-equal? input output) + "Return #t if the file trees at INPUT and OUTPUT are equal." + (define strip + (cute string-drop <> (string-length input))) + (define sibling + (compose (cut string-append output <>) strip)) + (define (file=? a b) + (and (eq? (stat:type (lstat a)) (stat:type (lstat b))) + (case (stat:type (lstat a)) + ((regular) + (equal? + (call-with-input-file a get-bytevector-all) + (call-with-input-file b get-bytevector-all))) + ((symlink) + (string=? (readlink a) (readlink b))) + (else + (error "what?" (lstat a)))))) + + (file-system-fold (const #t) + (lambda (name stat result) ; leaf + (and result + (file=? name (sibling name)))) + (lambda (name stat result) ; down + result) + (lambda (name stat result) ; up + result) + (const #f) ; skip + (lambda (name stat errno result) + (pk 'error name stat errno) + #f) + (> (stat:nlink (stat output)) 2) + input + lstat)) + +(define (make-random-bytevector n) + (let ((bv (make-bytevector n))) + (let loop ((i 0)) + (if (< i n) + (begin + (bytevector-u8-set! bv i (random 256)) + (loop (1+ i))) + bv)))) + +(define (populate-file file size) + (call-with-output-file file + (lambda (p) + (put-bytevector p (make-random-bytevector size))))) + (define (rm-rf dir) (file-system-fold (const #t) ; enter? (lambda (file stat result) ; leaf @@ -39,15 +151,18 @@ dir lstat)) +(define %test-dir + ;; An output directory under $top_builddir. + (string-append (dirname (search-path %load-path "configure")) + "/test-nar-" (number->string (getpid)))) + (test-begin "nar") (test-assert "write-file + restore-file" (let* ((input (string-append (dirname (search-path %load-path "guix.scm")) "/guix")) - (output (string-append (dirname input) - "/test-nar-" - (number->string (getpid)))) + (output %test-dir) (nar (string-append output ".nar"))) (dynamic-wind (lambda () #t) @@ -56,40 +171,40 @@ (cut write-file input <>)) (call-with-input-file nar (cut restore-file <> output)) - (let* ((strip (cute string-drop <> (string-length input))) - (sibling (compose (cut string-append output <>) strip)) - (file=? (lambda (a b) - (and (eq? (stat:type (lstat a)) (stat:type (lstat b))) - (case (stat:type (lstat a)) - ((regular) - (equal? - (call-with-input-file a get-bytevector-all) - (call-with-input-file b get-bytevector-all))) - ((symlink) - (string=? (readlink a) (readlink b))) - (else - (error "what?" (lstat a)))))))) - (file-system-fold (const #t) - (lambda (name stat result) ; leaf - (and result - (file=? name (sibling name)))) - (lambda (name stat result) ; down - result) - (lambda (name stat result) ; up - result) - (const #f) ; skip - (lambda (name stat errno result) - (pk 'error name stat errno) - #f) - (> (stat:nlink (stat output)) 2) - input - lstat))) + (file-tree-equal? input output)) (lambda () (false-if-exception (delete-file nar)) - (false-if-exception (rm-rf output)) - )))) + (false-if-exception (rm-rf output)))))) + +(test-assert "write-file + restore-file with symlinks" + (let ((input (string-append %test-dir ".input"))) + (mkdir input) + (dynamic-wind + (const #t) + (lambda () + (with-file-tree input + (directory "root" + (("reg") ("exe" #o777) ("sym" -> "reg"))) + (let* ((output %test-dir) + (nar (string-append output ".nar"))) + (dynamic-wind + (lambda () #t) + (lambda () + (call-with-output-file nar + (cut write-file input <>)) + (call-with-input-file nar + (cut restore-file <> output)) + (file-tree-equal? input output)) + (lambda () + (false-if-exception (delete-file nar))))))) + (lambda () + (rmdir input))))) (test-end "nar") (exit (= (test-runner-fail-count (test-runner-current)) 0)) + +;;; Local Variables: +;;; eval: (put 'with-file-tree 'scheme-indent-function 2) +;;; End: -- cgit 1.4.1 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') 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 1.4.1 From 77ffd691bfbb152cde94b60aa8df5135d39727c3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Apr 2013 18:40:22 +0200 Subject: tests: Remove temporary directory created by nar.scm. * tests/nar.scm ("write-file + restore-file with symlinks"): Add (rm-rf output). --- tests/nar.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/nar.scm b/tests/nar.scm index 4321cbda53..9bc5a1962e 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -196,7 +196,8 @@ (cut restore-file <> output)) (file-tree-equal? input output)) (lambda () - (false-if-exception (delete-file nar))))))) + (false-if-exception (delete-file nar)) + (false-if-exception (rm-rf output))))))) (lambda () (rmdir input))))) -- cgit 1.4.1 From 04fd96cac33fa7557e574e54575252564ba27111 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 14 Apr 2013 16:56:08 +0200 Subject: utils: Add `fold2'. * gnu/packages.scm (fold2): Remove. * guix/utils.scm (fold2): New procedure. Generalization of the above to one and two lists. * tests/utils.scm ("fold2, 1 list", "fold2, 2 lists"): New tests. --- gnu/packages.scm | 8 -------- guix/utils.scm | 29 ++++++++++++++++++++++++++++- tests/utils.scm | 25 +++++++++++++++++++++++++ 3 files changed, 53 insertions(+), 9 deletions(-) (limited to 'tests') diff --git a/gnu/packages.scm b/gnu/packages.scm index b639541788..f4d93a789d 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -110,14 +110,6 @@ (false-if-exception (resolve-interface name)))) (package-files))) -(define (fold2 f seed1 seed2 lst) - (if (null? lst) - (values seed1 seed2) - (call-with-values - (lambda () (f (car lst) seed1 seed2)) - (lambda (seed1 seed2) - (fold2 f seed1 seed2 (cdr lst)))))) - (define (fold-packages proc init) "Call (PROC PACKAGE RESULT) for each available package, using INIT as the initial value of RESULT. It is guaranteed to never traverse the diff --git a/guix/utils.scm b/guix/utils.scm index d7c37e37d1..f13e585e2b 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -59,7 +59,8 @@ %current-system version-compare version>? - package-name->name+version)) + package-name->name+version + fold2)) ;;; @@ -463,6 +464,32 @@ introduce the version part." ((head tail ...) (loop tail (cons head prefix)))))) +(define fold2 + (case-lambda + ((proc seed1 seed2 lst) + "Like `fold', but with a single list and two seeds." + (let loop ((result1 seed1) + (result2 seed2) + (lst lst)) + (if (null? lst) + (values result1 result2) + (call-with-values + (lambda () (proc (car lst) result1 result2)) + (lambda (result1 result2) + (loop result1 result2 (cdr lst))))))) + ((proc seed1 seed2 lst1 lst2) + "Like `fold', but with a two lists and two seeds." + (let loop ((result1 seed1) + (result2 seed2) + (lst1 lst1) + (lst2 lst2)) + (if (or (null? lst1) (null? lst2)) + (values result1 result2) + (call-with-values + (lambda () (proc (car lst1) (car lst2) result1 result2)) + (lambda (result1 result2) + (fold2 proc result1 result2 (cdr lst1) (cdr lst2))))))))) + ;;; ;;; Source location. diff --git a/tests/utils.scm b/tests/utils.scm index bcdd120a74..fa7d7b03fd 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -64,6 +64,31 @@ ("nixpkgs" "1.0pre22125_a28fe19") ("gtk2" "2.38.0")))) +(test-equal "fold2, 1 list" + (list (reverse (iota 5)) + (map - (reverse (iota 5)))) + (call-with-values + (lambda () + (fold2 (lambda (i r1 r2) + (values (cons i r1) + (cons (- i) r2))) + '() '() + (iota 5))) + list)) + +(test-equal "fold2, 2 lists" + (list (reverse '((a . 0) (b . 1) (c . 2) (d . 3))) + (reverse '((a . 0) (b . -1) (c . -2) (d . -3)))) + (call-with-values + (lambda () + (fold2 (lambda (k v r1 r2) + (values (alist-cons k v r1) + (alist-cons k (- v) r2))) + '() '() + '(a b c d) + '(0 1 2 3))) + list)) + (test-assert "define-record-type*" (begin (define-record-type* foo make-foo -- cgit 1.4.1 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') 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 1.4.1 From dd36b51bf7cffa389726ad997465b14f7072944a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 17 Apr 2013 00:06:59 +0200 Subject: scripts: Report what will be substituted. * guix/derivations.scm (derivation-input-output-paths): New procedure. (derivation-prerequisites-to-build): New `use-substitutes?' keyword argument. Change two return the list of substitutable paths as a second argument. * guix/ui.scm (show-what-to-build): Turn `dry-run?' into a keyword argument. New `use-substitutes?' keyword argument. Use `fold2' and adjust to use both return values of `derivation-prerequisites-to-build'. Display what will/would be downloaded. * guix/scripts/build.scm (guix-build): Adjust accordingly. * guix/scripts/package.scm (guix-package): Likewise. * tests/derivations.scm ("derivation-prerequisites-to-build and substitutes"): New test. --- guix/derivations.scm | 117 +++++++++++++++++++++++++++++++++-------------- guix/scripts/build.scm | 4 +- guix/scripts/package.scm | 4 +- guix/ui.scm | 81 ++++++++++++++++++++++---------- tests/derivations.scm | 46 +++++++++++++++++++ 5 files changed, 191 insertions(+), 61 deletions(-) (limited to 'tests') diff --git a/guix/derivations.scm b/guix/derivations.scm index 2243d2ba46..cf329819c4 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -48,6 +48,7 @@ derivation-input? derivation-input-path derivation-input-sub-derivations + derivation-input-output-paths fixed-output-derivation? derivation-hash @@ -99,6 +100,14 @@ download with a fixed hash (aka. `fetchurl')." #t) (_ #f))) +(define (derivation-input-output-paths input) + "Return the list of output paths corresponding to INPUT, a +." + (match input + (($ path sub-drvs) + (map (cut derivation-path->output-path path <>) + sub-drvs)))) + (define (derivation-prerequisites drv) "Return the list of derivation-inputs required to build DRV, recursively." (let loop ((drv drv) @@ -113,47 +122,85 @@ download with a fixed hash (aka. `fetchurl')." inputs))))) (define* (derivation-prerequisites-to-build store drv - #:key (outputs - (map - car - (derivation-outputs drv)))) - "Return the list of derivation-inputs required to build the OUTPUTS of -DRV and not already available in STORE, recursively." + #:key + (outputs + (map + car + (derivation-outputs drv))) + (use-substitutes? #t)) + "Return two values: the list of derivation-inputs required to build the +OUTPUTS of DRV and not already available in STORE, recursively, and the list +of required store paths that can be substituted. When USE-SUBSTITUTES? is #f, +that second value is the empty list." + (define (derivation-output-paths drv sub-drvs) + (match drv + (($ outputs) + (map (lambda (sub-drv) + (derivation-output-path (assoc-ref outputs sub-drv))) + sub-drvs)))) + (define built? (cut valid-path? store <>)) + (define substitutable? + ;; Return true if the given path is substitutable. Call + ;; `substitutable-paths' upfront, to benefit from parallelism in the + ;; substituter. + (if use-substitutes? + (let ((s (substitutable-paths store + (append + (derivation-output-paths drv outputs) + (append-map + derivation-input-output-paths + (derivation-prerequisites drv)))))) + (cut member <> s)) + (const #f))) + (define input-built? - (match-lambda - (($ path sub-drvs) - (let ((out (map (cut derivation-path->output-path path <>) - sub-drvs))) - (any built? out))))) + (compose (cut any built? <>) derivation-input-output-paths)) + + (define input-substitutable? + ;; Return true if and only if all of SUB-DRVS are subsitutable. If at + ;; least one is missing, then everything must be rebuilt. + (compose (cut every substitutable? <>) derivation-input-output-paths)) (define (derivation-built? drv sub-drvs) - (match drv - (($ outputs) - (let ((paths (map (lambda (sub-drv) - (derivation-output-path - (assoc-ref outputs sub-drv))) - sub-drvs))) - (every built? paths))))) - - (let loop ((drv drv) - (sub-drvs outputs) - (result '())) - (if (derivation-built? drv sub-drvs) - result - (let ((inputs (remove (lambda (i) - (or (member i result) ; XXX: quadratic - (input-built? i))) - (derivation-inputs drv)))) - (fold loop - (append inputs result) - (map (lambda (i) - (call-with-input-file (derivation-input-path i) - read-derivation)) - inputs) - (map derivation-input-sub-derivations inputs)))))) + (every built? (derivation-output-paths drv sub-drvs))) + + (define (derivation-substitutable? drv sub-drvs) + (every substitutable? (derivation-output-paths drv sub-drvs))) + + (let loop ((drv drv) + (sub-drvs outputs) + (build '()) + (substitute '())) + (cond ((derivation-built? drv sub-drvs) + (values build substitute)) + ((derivation-substitutable? drv sub-drvs) + (values build + (append (derivation-output-paths drv sub-drvs) + substitute))) + (else + (let ((inputs (remove (lambda (i) + (or (member i build) ; XXX: quadratic + (input-built? i) + (input-substitutable? i))) + (derivation-inputs drv)))) + (fold2 loop + (append inputs build) + (append (append-map (lambda (input) + (if (and (not (input-built? input)) + (input-substitutable? input)) + (derivation-input-output-paths + input) + '())) + (derivation-inputs drv)) + substitute) + (map (lambda (i) + (call-with-input-file (derivation-input-path i) + read-derivation)) + inputs) + (map derivation-input-sub-derivations inputs))))))) (define (%read-derivation drv-port) ;; Actually read derivation from DRV-PORT. diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 339ad0d06f..f296f3031f 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -237,7 +237,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (_ #f)) opts))) - (show-what-to-build (%store) drv (assoc-ref opts 'dry-run?)) + (show-what-to-build (%store) drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?)) ;; TODO: Add more options. (set-build-options (%store) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5b340c6ab7..f83c0573e7 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -674,7 +674,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (ensure-default-profile)) (show-what-to-remove/install remove* install* dry-run?) - (show-what-to-build (%store) drv dry-run?) + (show-what-to-build (%store) drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? dry-run?) (or dry-run? (and (build-derivations (%store) drv) diff --git a/guix/ui.scm b/guix/ui.scm index dfb6418a10..db0711bb61 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -144,33 +144,66 @@ error." (leave (_ "expression `~s' does not evaluate to a package~%") exp))))) -(define* (show-what-to-build store drv #:optional dry-run?) +(define* (show-what-to-build store drv + #:key dry-run? (use-substitutes? #t)) "Show what will or would (depending on DRY-RUN?) be built in realizing the derivations listed in DRV. Return #t if there's something to build, #f -otherwise." - (let* ((req (append-map (lambda (drv-path) - (let ((d (call-with-input-file drv-path - read-derivation))) - (derivation-prerequisites-to-build - store d))) - drv)) - (req* (delete-duplicates - (append (remove (compose (cute valid-path? store <>) - derivation-path->output-path) - drv) - (map derivation-input-path req))))) +otherwise. When USE-SUBSTITUTES?, check and report what is prerequisites are +available for download." + (let*-values (((build download) + (fold2 (lambda (drv-path build download) + (let ((drv (call-with-input-file drv-path + read-derivation))) + (let-values (((b d) + (derivation-prerequisites-to-build + store drv + #:use-substitutes? + use-substitutes?))) + (values (append b build) + (append d download))))) + '() '() + drv)) + ((build) ; add the DRV themselves + (delete-duplicates + (append (remove (compose (lambda (out) + (or (valid-path? store out) + (and use-substitutes? + (has-substitutes? store + out)))) + derivation-path->output-path) + drv) + (map derivation-input-path build)))) + ((download) ; add the references of DOWNLOAD + (delete-duplicates + (append download + (remove (cut valid-path? store <>) + (append-map + substitutable-references + (substitutable-path-info store download))))))) (if dry-run? - (format (current-error-port) - (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*) - (format (current-error-port) - (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" - "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" - (length req*)) - (null? req*) req*)) - (pair? req*))) + (begin + (format (current-error-port) + (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations would be built:~%~{ ~a~%~}~;~]" + (length build)) + (null? build) build) + (format (current-error-port) + (N_ "~:[the following file would be downloaded:~%~{ ~a~%~}~;~]" + "~:[the following files would be downloaded:~%~{ ~a~%~}~;~]" + (length download)) + (null? download) download)) + (begin + (format (current-error-port) + (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]" + "~:[the following derivations will be built:~%~{ ~a~%~}~;~]" + (length build)) + (null? build) build) + (format (current-error-port) + (N_ "~:[the following file will be downloaded:~%~{ ~a~%~}~;~]" + "~:[the following files will be downloaded:~%~{ ~a~%~}~;~]" + (length download)) + (null? download) download))) + (pair? build))) (define-syntax with-error-handling (syntax-rules () diff --git a/tests/derivations.scm b/tests/derivations.scm index 6012e73216..a50c1af878 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -32,6 +32,7 @@ #:use-module (srfi srfi-64) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) + #:use-module (web uri) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 ftw) @@ -398,6 +399,51 @@ ;; prerequisite to build because DRV itself is already built. (null? (derivation-prerequisites-to-build %store drv))))) +(test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1)) +(test-assert "derivation-prerequisites-to-build and substitutes" + (let*-values (((store) + (open-connection)) + ((drv-path drv) + (build-expression->derivation store "prereq-subst" + (%current-system) + (random 1000) '())) + ((output) + (derivation-output-path + (assoc-ref (derivation-outputs drv) "out"))) + ((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 "/" (store-path-hash-part output) + ".narinfo") + (lambda (p) + (format p "StorePath: ~a +URL: ~a +Compression: none +NarSize: 1234 +References: +System: ~a +Deriver: ~a~%" + output ; StorePath + (string-append dir "/example.nar") ; URL + (%current-system) ; System + (basename drv-path)))) ; Deriver + + (let-values (((build download) + (derivation-prerequisites-to-build store drv)) + ((build* download*) + (derivation-prerequisites-to-build store drv + #:use-substitutes? #f))) + (pk build download build* download*) + (and (null? build) + (equal? download (list output)) + (null? download*) + (null? build*))))) + (test-assert "build-expression->derivation with expression returning #f" (let* ((builder '(begin (mkdir %output) -- cgit 1.4.1 From 6c1cd80d8fcba1c5cfbd872e714c0e5603c1a3e4 Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov Date: Thu, 18 Apr 2013 15:22:40 +0000 Subject: tests: Use a new synopsis of GNU Hello. * tests/guix-package.sh: Use a new synopsis of GNU Hello, which was added in f50d2669e3e624365221cc81918ba55fdce94107. --- tests/guix-package.sh | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) (limited to 'tests') diff --git a/tests/guix-package.sh b/tests/guix-package.sh index f84893ba0b..7b101aa501 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -62,18 +62,19 @@ then # name and version string. installed="`guix package -p "$profile" --list-installed | cut -f1 | xargs echo | sort`" case "x$installed" in - "guile-bootstrap make-boot0") - true;; - "make-boot0 guile-bootstrap") - true;; - "*") + "guile-bootstrap make-boot0") + true;; + "make-boot0 guile-bootstrap") + true;; + "*") false;; esac test "`guix package -p "$profile" -I 'g.*e' | cut -f1`" = "guile-bootstrap" # Search. - test "`guix package -s "GNU Hello" | grep ^name:`" = "name: hello" + test "`guix package -s "An example GNU package" | grep ^name:`" = \ + "name: hello" test "`guix package -s "n0t4r341p4ck4g3"`" = "" # Remove a package. @@ -92,10 +93,10 @@ then # Move to the empty profile. for i in `seq 1 3` do - guix package --bootstrap --roll-back -p "$profile" - ! test -f "$profile/bin" - ! test -f "$profile/lib" - test "`readlink_base "$profile"`" = "$profile-0-link" + guix package --bootstrap --roll-back -p "$profile" + ! test -f "$profile/bin" + ! test -f "$profile/lib" + test "`readlink_base "$profile"`" = "$profile-0-link" done # Reinstall after roll-back to the empty profile. -- cgit 1.4.1 From d66c70967f9bd792acdd00036292dc0a7b858742 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 22 Apr 2013 23:07:13 +0200 Subject: packages: Add `package-field-location'. * guix/packages.scm (package-field-location): New procedure. * build-aux/sync-synopses.scm: Use it instead of `package-location'. * tests/packages.scm ("package-field-location"): New test. --- build-aux/sync-synopses.scm | 2 +- guix/packages.scm | 47 +++++++++++++++++++++++++++++++++++++++++++++ tests/packages.scm | 21 ++++++++++++++++++++ 3 files changed, 69 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/build-aux/sync-synopses.scm b/build-aux/sync-synopses.scm index 9aaff11ce0..3681b8c623 100644 --- a/build-aux/sync-synopses.scm +++ b/build-aux/sync-synopses.scm @@ -52,7 +52,7 @@ ((package . descriptor) (let ((upstream (gnu-package-doc-summary descriptor)) (downstream (package-synopsis package)) - (loc (package-location package))) + (loc (package-field-location package 'synopsis))) (unless (and upstream (string=? upstream downstream)) (format (guix-warning-port) "~a: ~a: proposed synopsis: ~s~%" diff --git a/guix/packages.scm b/guix/packages.scm index 81f09d638e..8490bfe438 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -28,6 +28,8 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module ((ice-9 rdelim) #:select (read-line)) + #:use-module (ice-9 regex) #:re-export (%current-system) #:export (origin origin? @@ -58,6 +60,7 @@ package-maintainers package-properties package-location + package-field-location package-transitive-inputs package-transitive-propagated-inputs @@ -159,6 +162,50 @@ representation." package) 16))))) +(define (package-field-location package field) + "Return an estimate of the source code location of the definition of FIELD +for PACKAGE." + (define field-rx + (make-regexp (string-append "\\(" + (regexp-quote (symbol->string field)) + "[[:blank:]]*"))) + (define (seek-to-line port line) + (let ((line (- line 1))) + (let loop () + (when (< (port-line port) line) + (unless (eof-object? (read-line port)) + (loop)))))) + + (define (find-line port) + (let loop ((line (read-line port))) + (cond ((eof-object? line) + (values #f #f)) + ((regexp-exec field-rx line) + => + (lambda (match) + ;; At this point `port-line' points to the next line, so need + ;; need to add one. + (values (port-line port) + (match:end match)))) + (else + (loop (read-line port)))))) + + (match (package-location package) + (($ file line column) + (catch 'system + (lambda () + (call-with-input-file (search-path %load-path file) + (lambda (port) + (seek-to-line port line) + (let-values (((line column) + (find-line port))) + (if (and line column) + (location file line column) + (package-location package)))))) + (lambda _ + (package-location package)))) + (_ #f))) + ;; Error conditions. diff --git a/tests/packages.scm b/tests/packages.scm index c5d9d280ed..bf82aba858 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -52,6 +52,27 @@ (home-page #f) (license #f) extra-fields ...)) +(test-assert "package-field-location" + (let () + (define (goto port line column) + (unless (and (= (port-column port) (- column 1)) + (= (port-line port) (- line 1))) + (unless (eof-object? (get-char port)) + (goto port line column)))) + + (define read-at + (match-lambda + (($ file line column) + (call-with-input-file (search-path %load-path file) + (lambda (port) + (goto port line column) + (read port)))))) + + (and (equal? (read-at (package-field-location %bootstrap-guile 'name)) + (package-name %bootstrap-guile)) + (equal? (read-at (package-field-location %bootstrap-guile 'version)) + (package-version %bootstrap-guile))))) + (test-assert "package-transitive-inputs" (let* ((a (dummy-package "a")) (b (dummy-package "b" -- cgit 1.4.1 From f903dc056a5176033daca7a69d5b2c8376ff0677 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 24 Apr 2013 14:43:31 +0200 Subject: packages: Use `read' and source properties for `package-field-location'. * guix/packages.scm (package-field-location): Rewrite using `read' and source properties. Change to return #f upon failure. * tests/packages.scm ("package-field-location"): Check for #f upon failure. * build-aux/sync-synopses.scm: Adjust accordingly. --- build-aux/sync-synopses.scm | 3 ++- guix/packages.scm | 56 +++++++++++++++++---------------------------- tests/packages.scm | 3 ++- 3 files changed, 25 insertions(+), 37 deletions(-) (limited to 'tests') diff --git a/build-aux/sync-synopses.scm b/build-aux/sync-synopses.scm index 3681b8c623..c1049d3398 100644 --- a/build-aux/sync-synopses.scm +++ b/build-aux/sync-synopses.scm @@ -52,7 +52,8 @@ ((package . descriptor) (let ((upstream (gnu-package-doc-summary descriptor)) (downstream (package-synopsis package)) - (loc (package-field-location package 'synopsis))) + (loc (or (package-field-location package 'synopsis) + (package-location package)))) (unless (and upstream (string=? upstream downstream)) (format (guix-warning-port) "~a: ~a: proposed synopsis: ~s~%" diff --git a/guix/packages.scm b/guix/packages.scm index 8490bfe438..ec5420f6c0 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -28,8 +28,6 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:use-module ((ice-9 rdelim) #:select (read-line)) - #:use-module (ice-9 regex) #:re-export (%current-system) #:export (origin origin? @@ -163,32 +161,13 @@ representation." 16))))) (define (package-field-location package field) - "Return an estimate of the source code location of the definition of FIELD -for PACKAGE." - (define field-rx - (make-regexp (string-append "\\(" - (regexp-quote (symbol->string field)) - "[[:blank:]]*"))) - (define (seek-to-line port line) - (let ((line (- line 1))) - (let loop () - (when (< (port-line port) line) - (unless (eof-object? (read-line port)) - (loop)))))) - - (define (find-line port) - (let loop ((line (read-line port))) - (cond ((eof-object? line) - (values #f #f)) - ((regexp-exec field-rx line) - => - (lambda (match) - ;; At this point `port-line' points to the next line, so need - ;; need to add one. - (values (port-line port) - (match:end match)))) - (else - (loop (read-line port)))))) + "Return the source code location of the definition of FIELD for PACKAGE, or +#f if it could not be determined." + (define (goto port line column) + (unless (and (= (port-column port) (- column 1)) + (= (port-line port) (- line 1))) + (unless (eof-object? (read-char port)) + (goto port line column)))) (match (package-location package) (($ file line column) @@ -196,14 +175,21 @@ for PACKAGE." (lambda () (call-with-input-file (search-path %load-path file) (lambda (port) - (seek-to-line port line) - (let-values (((line column) - (find-line port))) - (if (and line column) - (location file line column) - (package-location package)))))) + (goto port line column) + (match (read port) + (('package inits ...) + (let ((field (assoc field inits))) + (match field + ((_ value) + (and=> (or (source-properties value) + (source-properties field)) + source-properties->location)) + (_ + #f)))) + (_ + #f))))) (lambda _ - (package-location package)))) + #f))) (_ #f))) diff --git a/tests/packages.scm b/tests/packages.scm index bf82aba858..22985d6e9a 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -71,7 +71,8 @@ (and (equal? (read-at (package-field-location %bootstrap-guile 'name)) (package-name %bootstrap-guile)) (equal? (read-at (package-field-location %bootstrap-guile 'version)) - (package-version %bootstrap-guile))))) + (package-version %bootstrap-guile)) + (not (package-field-location %bootstrap-guile 'does-not-exist))))) (test-assert "package-transitive-inputs" (let* ((a (dummy-package "a")) -- cgit 1.4.1