diff options
| -rw-r--r-- | config-daemon.ac | 8 | ||||
| -rw-r--r-- | guix/config.scm.in | 14 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 100 | ||||
| -rw-r--r-- | tests/store.scm | 55 |
4 files changed, 154 insertions, 23 deletions
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 <narinfo> - (%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 <narinfo> object." - (%make-narinfo path url compression file-hash - (and=> file-size string->number) - nar-hash - (and=> nar-size string->number) - (string-tokenize references) - (match deriver - ((or #f "") #f) - (_ deriver)) - system)) +(define (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 <narinfo> 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 <narinfo> 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") |