summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-04-02 10:44:20 +0200
committerLudovic Courtès <ludo@gnu.org>2013-04-03 22:44:39 +0200
commitf65cf81a3cd15eab993e129977bca46972508b4b (patch)
tree81fea5351de590e66a985870f02aeb85bf33a3fc /guix
parentcf53ecf514301d3ffdfc33dea057b057ffb132d6 (diff)
Add preliminary binary substituter.
* guix/scripts/substitute-binary.scm: New file. * Makefile.am (MODULES): Add it. * nix/scripts/substitute-binary.in: New file. * config-daemon.ac: Produce nix/scripts/substitute-binary. * daemon.am (nodist_pkglibexec_SCRIPTS): Add nix/scripts/substitute-binary. * guix/store.scm (substitutable-path-info): Use the `query-substitutable-path-infos' RPC. * nix/nix-daemon/guix-daemon.cc (main): Honor `NIX_SUBSTITUTERS'. * pre-inst-env.in: Set `NIX_SUBSTITUTERS'. * test-env.in: Leave `NIX_SUBSTITUTERS' unchanged. Set `GUIX_BINARY_SUBSTITUTE_URL, and create $NIX_STATE_DIR/substituter-data. Run `guix-daemon' within `./pre-inst-env'. * tests/store.scm ("substitute query"): New test.
Diffstat (limited to 'guix')
-rwxr-xr-xguix/scripts/substitute-binary.scm232
-rw-r--r--guix/store.scm2
2 files changed, 233 insertions, 1 deletions
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
new file mode 100755
index 0000000000..6e886b6c96
--- /dev/null
+++ b/guix/scripts/substitute-binary.scm
@@ -0,0 +1,232 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts substitute-binary)
+ #:use-module (guix ui)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 threads)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (web uri)
+ #:use-module (web client)
+ #:use-module (web response)
+ #:export (guix-substitute-binary))
+
+;;; Comment:
+;;;
+;;; This is the "binary substituter". It is invoked by the daemon do check
+;;; for the existence of available "substitutes" (pre-built binaries), and to
+;;; actually use them as a substitute to building things locally.
+;;;
+;;; If possible, substitute a binary for the requested store path, using a Nix
+;;; "binary cache". This program implements the Nix "substituter" protocol.
+;;;
+;;; Code:
+
+(define (fields->alist port)
+ "Read recutils-style record from PORT and return them as a list of key/value
+pairs."
+ (define field-rx
+ (make-regexp "^([[:graph:]]+): (.*)$"))
+
+ (let loop ((line (read-line port))
+ (result '()))
+ (cond ((eof-object? line)
+ (reverse result))
+ ((regexp-exec field-rx line)
+ =>
+ (lambda (match)
+ (loop (read-line port)
+ (alist-cons (match:substring match 1)
+ (match:substring match 2)
+ result))))
+ (else
+ (error "unmatched line" line)))))
+
+(define (alist->record alist make keys)
+ "Apply MAKE to the values associated with KEYS in ALIST."
+ (let ((args (map (cut assoc-ref alist <>) keys)))
+ (apply make args)))
+
+(define (fetch uri)
+ (case (uri-scheme uri)
+ ((file)
+ (open-input-file (uri-path uri)))
+ ((http)
+ (let*-values (((resp port)
+ ;; XXX: `http-get*' was introduced in 2.0.7, and deprecated
+ ;; in 2.0.8 (!). Assume it is available here.
+ (if (version>? "2.0.7" (version))
+ (http-get* uri #:decode-body? #f)
+ (http-get uri #:streaming? #t)))
+ ((code)
+ (response-code resp))
+ ((size)
+ (response-content-length resp)))
+ (case code
+ ((200) ; OK
+ port)
+ ((301 ; moved permanently
+ 302) ; found (redirection)
+ (let ((uri (response-location resp)))
+ (format #t "following redirection to `~a'...~%"
+ (uri->string uri))
+ (fetch uri)))
+ (else
+ (error "download failed" (uri->string uri)
+ code (response-reason-phrase resp))))))))
+
+(define-record-type <cache>
+ (%make-cache url store-directory wants-mass-query?)
+ cache?
+ (url cache-url)
+ (store-directory cache-store-directory)
+ (wants-mass-query? cache-wants-mass-query?))
+
+(define (open-cache url)
+ "Open the binary cache at URL. Return a <cache> object on success, or #f on
+failure."
+ (define (download-cache-info url)
+ ;; Download the `nix-cache-info' from URL, and return its contents as an
+ ;; list of key/value pairs.
+ (and=> (false-if-exception (fetch (string->uri url)))
+ fields->alist))
+
+ (and=> (download-cache-info (string-append url "/nix-cache-info"))
+ (lambda (properties)
+ (alist->record properties
+ (cut %make-cache url <...>)
+ '("StoreDir" "WantMassQuery")))))
+
+(define-record-type <narinfo>
+ (%make-narinfo path url compression file-hash file-size nar-hash nar-size
+ references deriver system)
+ narinfo?
+ (path narinfo-path)
+ (url narinfo-url)
+ (compression narinfo-compression)
+ (file-hash narinfo-file-hash)
+ (file-size narinfo-file-size)
+ (nar-hash narinfo-hash)
+ (nar-size narinfo-size)
+ (references narinfo-references)
+ (deriver narinfo-deriver)
+ (system narinfo-system))
+
+(define (make-narinfo path url compression file-hash file-size nar-hash nar-size
+ references deriver system)
+ "Return a new <narinfo> object."
+ (%make-narinfo path url compression file-hash
+ (and=> file-size string->number)
+ nar-hash
+ (and=> nar-size string->number)
+ (string-tokenize references)
+ (match deriver
+ ((or #f "") #f)
+ (_ deriver))
+ system))
+
+(define (fetch-narinfo cache path)
+ "Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH."
+ (define (download url)
+ ;; Download the `nix-cache-info' from URL, and return its contents as an
+ ;; list of key/value pairs.
+ (and=> (false-if-exception (fetch (string->uri url)))
+ fields->alist))
+
+ (and=> (download (string-append (cache-url cache) "/"
+ (store-path-hash-part path)
+ ".narinfo"))
+ (lambda (properties)
+ (alist->record properties make-narinfo
+ '("StorePath" "URL" "Compression"
+ "FileHash" "FileSize" "NarHash" "NarSize"
+ "References" "Deriver" "System")))))
+
+(define %cache-url
+ (or (getenv "GUIX_BINARY_SUBSTITUTE_URL")
+ "http://hydra.gnu.org"))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-substitute-binary . args)
+ "Implement the build daemon's substituter protocol."
+ (match args
+ (("--query")
+ (let ((cache (open-cache %cache-url)))
+ (let loop ((command (read-line)))
+ (or (eof-object? command)
+ (begin
+ (match (string-tokenize command)
+ (("have" paths ..1)
+ ;; Return the subset of PATHS available in CACHE.
+ (let ((substitutable
+ (if cache
+ (par-map (cut fetch-narinfo cache <>)
+ paths)
+ '())))
+ (for-each (lambda (narinfo)
+ (when narinfo
+ (display (narinfo-path narinfo))
+ (newline)))
+ substitutable)))
+ (("info" paths ..1)
+ ;; Reply info about PATHS if it's in CACHE.
+ (let ((substitutable
+ (if cache
+ (par-map (cut fetch-narinfo cache <>)
+ paths)
+ '())))
+ (for-each (lambda (narinfo)
+ (format #t "~a\n~a\n~a\n"
+ (narinfo-path narinfo)
+ (or (and=> (narinfo-deriver narinfo)
+ (cute string-append
+ (%store-prefix) "/"
+ <>))
+ "")
+ (length (narinfo-references narinfo)))
+ (for-each (cute format #t "~a/~a~%"
+ (%store-prefix) <>)
+ (narinfo-references narinfo))
+ (format #t "~a\n~a\n"
+ (or (narinfo-file-size narinfo) 0)
+ (or (narinfo-size narinfo) 0))
+ (newline))
+ substitutable)))
+ (wtf
+ (error "unknown `--query' command" wtf)))
+ (loop (read-line)))))))
+ (("--substitute" store-path destination)
+ ;; Download PATH and add it to the store.
+ ;; TODO: Implement.
+ (format (current-error-port) "substitution not implemented yet~%")
+ #f)
+ (("--version")
+ (show-version-and-exit "guix substitute-binary"))))
+
+;;; substitute-binary.scm ends here
diff --git a/guix/store.scm b/guix/store.scm
index 3bb2656bb6..de9785c835 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -662,7 +662,7 @@ file name. Return #t on success."
store-path-list))
(define substitutable-path-info
- (operation (query-substitutable-paths (store-path-list paths))
+ (operation (query-substitutable-path-infos (store-path-list paths))
"Return information about the subset of PATHS that is
substitutable. For each substitutable path, a `substitutable?' object is
returned."