diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/linux-initrd.scm | 6 | ||||
| -rw-r--r-- | guix/config.scm.in | 5 | ||||
| -rw-r--r-- | guix/derivations.scm | 44 | ||||
| -rw-r--r-- | guix/hash.scm | 42 | ||||
| -rw-r--r-- | guix/licenses.scm | 8 | ||||
| -rw-r--r-- | guix/nar.scm | 229 | ||||
| -rw-r--r-- | guix/pki.scm | 23 | ||||
| -rw-r--r-- | guix/profiles.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/authenticate.scm | 24 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 380 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 5 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 25 | ||||
| -rw-r--r-- | guix/store.scm | 82 | ||||
| -rw-r--r-- | guix/ui.scm | 16 | ||||
| -rw-r--r-- | guix/utils.scm | 66 |
15 files changed, 899 insertions, 60 deletions
diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index cbdb363b4e..ae18a16e11 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -95,7 +95,9 @@ ;; Other useful nodes. (mknod (scope "dev/null") 'char-special #o666 (device-number 1 3)) - (mknod (scope "dev/zero") 'char-special #o666 (device-number 1 5))) + (mknod (scope "dev/zero") 'char-special #o666 (device-number 1 5)) + (chmod (scope "dev/null") #o666) + (chmod (scope "dev/zero") #o666)) (define %host-qemu-ipv4-address (inet-pton AF_INET "10.0.2.10")) diff --git a/guix/config.scm.in b/guix/config.scm.in index 3a5c50e00a..5edb4ced30 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -24,6 +24,7 @@ %store-directory %state-directory %config-directory + %guix-register-program %system %libgcrypt %nixpkgs @@ -62,6 +63,10 @@ ;; This must match `NIX_CONF_DIR' as defined in `daemon.am'. (or (getenv "NIX_CONF_DIR") "@guix_sysconfdir@/guix")) +(define %guix-register-program + ;; The 'guix-register' program. + (or (getenv "GUIX_REGISTER") "@guix_sbindir@/guix-register")) + (define %system "@guix_system@") diff --git a/guix/derivations.scm b/guix/derivations.scm index 3d9f0affbf..cc8e37c973 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -532,7 +532,8 @@ the derivation called NAME with hash HASH." (system (%current-system)) (env-vars '()) (inputs '()) (outputs '("out")) hash hash-algo hash-mode - references-graphs) + references-graphs + local-build?) "Build a derivation with the given arguments, and return the resulting <derivation> object. When HASH, HASH-ALGO, and HASH-MODE are given, a fixed-output derivation is created---i.e., one whose result is known in @@ -540,7 +541,11 @@ advance, such as a file download. When REFERENCES-GRAPHS is true, it must be a list of file name/store path pairs. In that case, the reference graph of each store path is exported in -the build environment in the corresponding file, in a simple text format." +the build environment in the corresponding file, in a simple text format. + +When LOCAL-BUILD? is true, declare that the derivation is not a good candidate +for offloading and should rather be built locally. This is the case for small +derivations where the costs of data transfers would outweigh the benefits." (define (add-output-paths drv) ;; Return DRV with an actual store path for each of its output and the ;; corresponding environment variable. @@ -571,16 +576,20 @@ the build environment in the corresponding file, in a simple text format." ;; Some options are passed to the build daemon via the env. vars of ;; derivations (urgh!). We hide that from our API, but here is the place ;; where we kludgify those options. - (match references-graphs - (((file . path) ...) - (let ((value (map (cut string-append <> " " <>) - file path))) - ;; XXX: This all breaks down if an element of FILE or PATH contains - ;; white space. - `(("exportReferencesGraph" . ,(string-join value " ")) - ,@env-vars))) - (#f - env-vars))) + (let ((env-vars (if local-build? + `(("preferLocalBuild" . "1") + ,@env-vars) + env-vars))) + (match references-graphs + (((file . path) ...) + (let ((value (map (cut string-append <> " " <>) + file path))) + ;; XXX: This all breaks down if an element of FILE or PATH contains + ;; white space. + `(("exportReferencesGraph" . ,(string-join value " ")) + ,@env-vars))) + (#f + env-vars)))) (define (env-vars-with-empty-outputs env-vars) ;; Return a variant of ENV-VARS where each OUTPUTS is associated with an @@ -904,7 +913,8 @@ they can refer to each other." (env-vars '()) (modules '()) guile-for-build - references-graphs) + references-graphs + local-build?) "Return a derivation that executes Scheme expression EXP as a builder for derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV) tuples; when SUB-DRV is omitted, \"out\" is assumed. MODULES is a list @@ -923,7 +933,8 @@ EXP returns #f, the build is considered to have failed. EXP is built using GUILE-FOR-BUILD (a derivation). When GUILE-FOR-BUILD is omitted or is #f, the value of the `%guile-for-build' fluid is used instead. -See the `derivation' procedure for the meaning of REFERENCES-GRAPHS." +See the `derivation' procedure for the meaning of REFERENCES-GRAPHS and +LOCAL-BUILD?." (define guile-drv (or guile-for-build (%guile-for-build))) @@ -1046,4 +1057,5 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS." #:hash hash #:hash-algo hash-algo #:outputs outputs - #:references-graphs references-graphs))) + #:references-graphs references-graphs + #:local-build? local-build?))) diff --git a/guix/hash.scm b/guix/hash.scm index 92ecaf78d5..fb85f47586 100644 --- a/guix/hash.scm +++ b/guix/hash.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,7 +25,8 @@ #:use-module (srfi srfi-11) #:export (sha256 open-sha256-port - port-sha256)) + port-sha256 + open-sha256-input-port)) ;;; Commentary: ;;; @@ -128,4 +129,41 @@ output port." (close-port out) (get))) +(define (open-sha256-input-port port) + "Return an input port that wraps PORT and a thunk to get the hash of all the +data read from PORT. The thunk always returns the same value." + (define md + (open-sha256-md)) + + (define (read! bv start count) + (let ((n (get-bytevector-n! port bv start count))) + (if (eof-object? n) + 0 + (begin + (unless digest + (let ((ptr (bytevector->pointer bv start))) + (md-write md ptr n))) + n)))) + + (define digest #f) + + (define (finalize!) + (let ((ptr (md-read md 0))) + (set! digest (bytevector-copy (pointer->bytevector ptr 32))) + (md-close md))) + + (define (get-hash) + (unless digest + (finalize!)) + digest) + + (define (unbuffered port) + ;; Guile <= 2.0.9 does not support 'setvbuf' on custom binary input ports. + ;; If you get a wrong-type-arg error here, the fix is to upgrade Guile. :-) + (setvbuf port _IONBF) + port) + + (values (unbuffered (make-custom-binary-input-port "sha256" read! #f #f #f)) + get-hash)) + ;;; hash.scm ends here diff --git a/guix/licenses.scm b/guix/licenses.scm index c0a0e60b36..5f1b3c16cf 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; @@ -31,6 +31,7 @@ expat freetype gpl1 gpl1+ gpl2 gpl2+ gpl3 gpl3+ + fdl1.3+ isc ijg ibmpl1.0 @@ -161,6 +162,11 @@ which may be a file:// URI pointing the package's tree." "https://www.gnu.org/licenses/gpl.html" "https://www.gnu.org/licenses/license-list#GNUGPLv3")) +(define fdl1.3+ + (license "FDL 1.3+" + "https://www.gnu.org/licenses/fdl.html" + "https://www.gnu.org/licenses/license-list#FDL")) + (define isc (license "ISC" "http://directory.fsf.org/wiki/License:ISC" diff --git a/guix/nar.scm b/guix/nar.scm index ea119a25fe..4bc2deb229 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,23 +19,40 @@ (define-module (guix nar) #:use-module (guix utils) #:use-module (guix serialization) - #:use-module ((guix build utils) #:select (with-directory-excursion)) + #:use-module ((guix build utils) + #:select (delete-file-recursively with-directory-excursion)) + #:use-module (guix store) + #:use-module (guix ui) ; for '_' + #:use-module (guix hash) + #:use-module (guix pki) + #:use-module (guix pk-crypto) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:export (nar-error? + nar-error-port + nar-error-file + nar-read-error? - nar-read-error-file - nar-read-error-port nar-read-error-token + nar-invalid-hash-error? + nar-invalid-hash-error-expected + nar-invalid-hash-error-actual + + nar-signature-error? + nar-signature-error-signature + write-file - restore-file)) + restore-file + + restore-file-set)) ;;; Comment: ;;; @@ -44,15 +61,24 @@ ;;; Code: (define-condition-type &nar-error &error ; XXX: inherit from &nix-error ? - nar-error?) + nar-error? + (file nar-error-file) ; file we were restoring, or #f + (port nar-error-port)) ; port from which we read (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-condition-type &nar-signature-error &nar-error + nar-signature-error? + (signature nar-signature-error-signature)) ; faulty signature or #f +(define-condition-type &nar-invalid-hash-error &nar-signature-error + nar-invalid-hash-error? + (expected nar-invalid-hash-error-expected) ; expected hash (a bytevector) + (actual nar-invalid-hash-error-actual)) ; actual hash + + (define (dump in out size) "Copy SIZE bytes from IN to OUT." (define buf-size 65536) @@ -239,4 +265,191 @@ Restore it as FILE." (&message (message "unsupported nar entry type")) (&nar-read-error (port port) (file file) (token x)))))))) + +;;; +;;; Restoring a file set into the store. +;;; + +;; The code below accesses the store directly and is meant to be run from +;; "build hooks", which cannot invoke the daemon's 'import-paths' RPC since +;; (1) the locks on the files to be restored as already held, and (2) the +;; $NIX_HELD_LOCKS hackish environment variable cannot be set. +;; +;; So we're really duplicating that functionality of the daemon (well, until +;; most of the daemon is in Scheme :-)). But note that we do use a couple of +;; RPCs for functionality not available otherwise, like 'valid-path?'. + +(define (lock-store-file file) + "Acquire exclusive access to FILE, a store file." + (call-with-output-file (string-append file ".lock") + (cut fcntl-flock <> 'write-lock))) + +(define (unlock-store-file file) + "Release access to FILE." + (call-with-input-file (string-append file ".lock") + (cut fcntl-flock <> 'unlock))) + +(define* (finalize-store-file source target + #:key (references '()) deriver (lock? #t)) + "Rename SOURCE to TARGET and register TARGET as a valid store item, with +REFERENCES and DERIVER. When LOCK? is true, acquire exclusive locks on TARGET +before attempting to register it; otherwise, assume TARGET's locks are already +held." + + ;; XXX: Currently we have to call out to the daemon to check whether TARGET + ;; is valid. + (with-store store + (unless (valid-path? store target) + (when lock? + (lock-store-file target)) + + (unless (valid-path? store target) + ;; If FILE already exists, delete it (it's invalid anyway.) + (when (file-exists? target) + (delete-file-recursively target)) + + ;; Install the new TARGET. + (rename-file source target) + + ;; Register TARGET. As a side effect, it resets the timestamps of all + ;; its files, recursively. However, it doesn't attempt to deduplicate + ;; its files like 'importPaths' does (FIXME). + (register-path target + #:references references + #:deriver deriver)) + + (when lock? + (unlock-store-file target))))) + +(define (temporary-store-directory) + "Return the file name of a temporary directory created in the store that is +protected from garbage collection." + (let* ((template (string-append (%store-prefix) "/guix-XXXXXX")) + (port (mkstemp! template))) + (close-port port) + (with-store store + (add-temp-root store template)) + + ;; There's a small window during which the GC could delete the file. Try + ;; again if that happens. + (if (file-exists? template) + (begin + ;; It's up to the caller to create that file or directory. + (delete-file template) + template) + (temporary-store-directory)))) + +(define* (restore-file-set port + #:key (verify-signature? #t) (lock? #t) + (log-port (current-error-port))) + "Restore the file set read from PORT to the store. The format of the data +on PORT must be as created by 'export-paths'---i.e., a series of Nar-formatted +archives with interspersed meta-data joining them together, possibly with a +digital signature at the end. Log progress to LOG-PORT. Return the list of +files restored. + +When LOCK? is #f, assume locks for the files to be restored are already held. +This is the case when the daemon calls a build hook. + +Note that this procedure accesses the store directly, so it's only meant to be +used by the daemon's build hooks since they cannot call back to the daemon +while the locks are held." + (define %export-magic + ;; Number used to identify genuine file set archives. + #x4558494e) + + (define port* + ;; Keep that one around, for error conditions. + port) + + (define (assert-valid-signature signature hash file) + ;; Bail out if SIGNATURE, an sexp, doesn't match HASH, a bytevector + ;; containing the expected hash for FILE. + (let* ((signature (catch 'gcry-error + (lambda () + (string->canonical-sexp signature)) + (lambda (err . _) + (raise (condition + (&message + (message "signature is not a valid \ +s-expression")) + (&nar-signature-error + (file file) + (signature signature) (port port))))))) + (subject (signature-subject signature)) + (data (signature-signed-data signature))) + (if (and data subject) + (if (authorized-key? subject) + (if (equal? (hash-data->bytevector data) hash) + (unless (valid-signature? signature) + (raise (condition + (&message (message "invalid signature")) + (&nar-signature-error + (file file) (signature signature) (port port))))) + (raise (condition (&message (message "invalid hash")) + (&nar-invalid-hash-error + (port port) (file file) + (signature signature) + (expected (hash-data->bytevector data)) + (actual hash))))) + (raise (condition (&message (message "unauthorized public key")) + (&nar-signature-error + (signature signature) (file file) (port port))))) + (raise (condition + (&message (message "corrupt signature data")) + (&nar-signature-error + (signature signature) (file file) (port port))))))) + + (let loop ((n (read-long-long port)) + (files '())) + (case n + ((0) + (reverse files)) + ((1) + (let-values (((port get-hash) + (open-sha256-input-port port))) + (let ((temp (temporary-store-directory))) + (restore-file port temp) + (let ((magic (read-int port))) + (unless (= magic %export-magic) + (raise (condition + (&message (message "corrupt file set archive")) + (&nar-read-error + (port port*) (file #f) (token #f)))))) + + (let ((file (read-store-path port)) + (refs (read-store-path-list port)) + (deriver (read-string port)) + (hash (get-hash)) + (has-sig? (= 1 (read-int port)))) + (format log-port + (_ "importing file or directory '~a'...~%") + file) + + (let ((sig (and has-sig? (read-string port)))) + (when verify-signature? + (if sig + (begin + (assert-valid-signature sig hash file) + (format log-port + (_ "found valid signature for '~a'~%") + file) + (finalize-store-file temp file + #:references refs + #:deriver deriver + #:lock? lock?) + (loop (read-long-long port) + (cons file files))) + (raise (condition + (&message (message "imported file lacks \ +a signature")) + (&nar-signature-error + (port port*) (file file) (signature #f))))))))))) + (else + ;; Neither 0 nor 1. + (raise (condition + (&message (message "invalid inter-file archive mark")) + (&nar-read-error + (port port) (file #f) (token #f)))))))) + ;;; nar.scm ends here diff --git a/guix/pki.scm b/guix/pki.scm index 5e4dbadd35..4b90b65a13 100644 --- a/guix/pki.scm +++ b/guix/pki.scm @@ -29,8 +29,12 @@ current-acl public-keys->acl acl->public-keys + authorized-key? + signature-sexp - authorized-key?)) + signature-subject + signature-signed-data + valid-signature?)) ;;; Commentary: ;;; @@ -136,4 +140,21 @@ PUBLIC-KEY (see <http://theworld.com/~cme/spki.txt> for examples.)" (canonical-sexp->string (sign data secret-key)) (canonical-sexp->string public-key)))) +(define (signature-subject sig) + "Return the signer's public key for SIG." + (find-sexp-token sig 'public-key)) + +(define (signature-signed-data sig) + "Return the signed data from SIG, typically an sexp such as + (hash \"sha256\" #...#)." + (find-sexp-token sig 'data)) + +(define (valid-signature? sig) + "Return #t if SIG is valid." + (let* ((data (signature-signed-data sig)) + (signature (find-sexp-token sig 'sig-val)) + (public-key (signature-subject sig))) + (and data signature + (verify signature data public-key)))) + ;;; pki.scm ends here diff --git a/guix/profiles.scm b/guix/profiles.scm index 9b5c5f515c..1ff6c97f9f 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; ;;; This file is part of GNU Guix. @@ -238,8 +238,6 @@ the given MANIFEST." (let ((output (assoc-ref %outputs "out")) (inputs (map cdr %build-inputs))) - (format #t "building profile '~a' with ~a packages...~%" - output (length inputs)) (union-build output inputs #:log-port (%make-void-port "w")) (call-with-output-file (string-append output "/manifest") diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index c7a14f7a8b..27580dedff 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -72,23 +72,21 @@ ;; Read the signature as produced above, check whether its public key is ;; authorized, and verify the signature, and print the signed data to ;; stdout upon success. - (let* ((sig+data (read-canonical-sexp signature-file)) - (public-key (find-sexp-token sig+data 'public-key)) - (data (find-sexp-token sig+data 'data)) - (signature (find-sexp-token sig+data 'sig-val))) - (if (and data signature) - (if (authorized-key? public-key) - (if (verify signature data public-key) - (begin - (display (bytevector->base16-string - (hash-data->bytevector data))) + (let* ((signature (read-canonical-sexp signature-file)) + (subject (signature-subject signature)) + (data (signature-signed-data signature))) + (if (and data subject) + (if (authorized-key? subject) + (if (valid-signature? signature) + (let ((hash (hash-data->bytevector data))) + (display (bytevector->base16-string hash)) #t) ; success (leave (_ "error: invalid signature: ~a~%") (canonical-sexp->string signature))) (leave (_ "error: unauthorized public key: ~a~%") - (canonical-sexp->string public-key))) + (canonical-sexp->string subject))) (leave (_ "error: corrupt signature data: ~a~%") - (canonical-sexp->string sig+data))))) + (canonical-sexp->string signature))))) (("--help") (display (_ "Usage: guix authenticate OPTION... Sign or verify the signature on the given file. This tool is meant to diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm new file mode 100644 index 0000000000..d919ede3c7 --- /dev/null +++ b/guix/scripts/offload.scm @@ -0,0 +1,380 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 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 offload) + #:use-module (guix config) + #:use-module (guix records) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix nar) + #:use-module (guix utils) + #:use-module ((guix build utils) #:select (which)) + #:use-module (guix ui) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 format) + #:use-module (rnrs io ports) + #:export (build-machine + build-requirements + guix-offload)) + +;;; Commentary: +;;; +;;; Attempt to offload builds to the machines listed in +;;; /etc/guix/machines.scm, transferring missing dependencies over SSH, and +;;; retrieving the build output(s) over SSH upon success. +;;; +;;; This command should not be used directly; instead, it is called on-demand +;;; by the daemon, unless it was started with '--no-build-hook' or a client +;;; inhibited build hooks. +;;; +;;; Code: + + +(define-record-type* <build-machine> + build-machine make-build-machine + build-machine? + (name build-machine-name) ; string + (system build-machine-system) ; string + (user build-machine-user) ; string + (private-key build-machine-private-key ; file name + (default (user-lsh-private-key))) + (parallel-builds build-machine-parallel-builds ; number + (default 1)) + (speed build-machine-speed ; inexact real + (default 1.0)) + (features build-machine-features ; list of strings + (default '()))) + +(define-record-type* <build-requirements> + build-requirements make-build-requirements + build-requirements? + (system build-requirements-system) ; string + (features build-requirements-features ; list of strings + (default '()))) + +(define %machine-file + ;; File that lists machines available as build slaves. + (string-append %config-directory "/machines.scm")) + +(define %lsh-command + "lsh") + +(define %lshg-command + ;; FIXME: 'lshg' fails to pass large amounts of data, see + ;; <http://lists.lysator.liu.se/pipermail/lsh-bugs/2014q1/000639.html>. + "lsh") + +(define (user-lsh-private-key) + "Return the user's default lsh private key, or #f if it could not be +determined." + (and=> (getenv "HOME") + (cut string-append <> "/.lsh/identity"))) + +(define %user-module + ;; Module in which the machine description file is loaded. + (let ((module (make-fresh-user-module))) + (module-use! module (resolve-interface '(guix scripts offload))) + module)) + +(define* (build-machines #:optional (file %machine-file)) + "Read the list of build machines from FILE and return it." + (catch #t + (lambda () + ;; Avoid ABI incompatibility with the <build-machine> record. + (set! %fresh-auto-compile #t) + + (save-module-excursion + (lambda () + (set-current-module %user-module) + (primitive-load %machine-file)))) + (lambda args + (match args + (('system-error . _) + (let ((err (system-error-errno args))) + ;; Silently ignore missing file since this is a common case. + (if (= ENOENT err) + '() + (leave (_ "failed to open machine file '~a': ~a~%") + %machine-file (strerror err))))) + (_ + (leave (_ "failed to load machine file '~a': ~s~%") + %machine-file args)))))) + +(define (open-ssh-gateway machine) + "Initiate an SSH connection gateway to MACHINE, and return the PID of the +running lsh gateway upon success, or #f on failure." + (catch 'system-error + (lambda () + (let* ((port (open-pipe* OPEN_READ %lsh-command + "-l" (build-machine-user machine) + "-i" (build-machine-private-key machine) + ;; XXX: With lsh 2.1, passing '--write-pid' + ;; last causes the PID not to be printed. + "--write-pid" "--gateway" "--background" "-z" + (build-machine-name machine))) + (line (read-line port)) + (status (close-pipe port))) + (if (zero? status) + (let ((pid (string->number line))) + (if (integer? pid) + pid + (begin + (warning (_ "'~a' did not write its PID on stdout: ~s~%") + %lsh-command line) + #f))) + (begin + (warning (_ "failed to initiate SSH connection to '~a':\ + '~a' exited with ~a~%") + (build-machine-name machine) + %lsh-command + (status:exit-val status)) + #f)))) + (lambda args + (leave (_ "failed to execute '~a': ~a~%") + %lsh-command (strerror (system-error-errno args)))))) + +(define (remote-pipe machine mode command) + "Run COMMAND on MACHINE, assuming an lsh gateway has been set up." + (catch 'system-error + (lambda () + (apply open-pipe* mode %lshg-command + "-l" (build-machine-user machine) "-z" + (build-machine-name machine) + command)) + (lambda args + (warning (_ "failed to execute '~a': ~a~%") + %lshg-command (strerror (system-error-errno args))) + #f))) + +(define* (offload drv machine + #:key print-build-trace? (max-silent-time 3600) + (build-timeout 7200)) + "Perform DRV on MACHINE, assuming DRV and its prerequisites are available +there. Return a read pipe from where to read the build log." + (format (current-error-port) "offloading '~a' to '~a'...~%" + (derivation-file-name drv) (build-machine-name machine)) + (format (current-error-port) "@ build-remote ~a ~a~%" + (derivation-file-name drv) (build-machine-name machine)) + + ;; FIXME: Protect DRV from garbage collection on MACHINE. + (let ((pipe (remote-pipe machine OPEN_READ + `("guix" "build" + ;; FIXME: more options + ,(format #f "--max-silent-time=~a" + max-silent-time) + ,(derivation-file-name drv))))) + pipe)) + +(define (send-files files machine) + "Send the subset of FILES that's missing to MACHINE's store. Return #t on +success, #f otherwise." + (define (missing-files files) + ;; Return the subset of FILES not already on MACHINE. + (let* ((files (format #f "~{~a~%~}" files)) + (missing (filtered-port + (list (which %lshg-command) + "-l" (build-machine-user machine) + "-i" (build-machine-private-key machine) + (build-machine-name machine) + "guix" "archive" "--missing") + (open-input-string files)))) + (string-tokenize (get-string-all missing)))) + + (with-store store + (guard (c ((nix-protocol-error? c) + (warning (_ "failed to export files for '~a': ~s~%") + (build-machine-name machine) + c) + (false-if-exception (close-pipe pipe)) + #f)) + + ;; Compute the subset of FILES missing on MACHINE, and send them in + ;; topologically sorted order so that they can actually be imported. + (let ((files (missing-files (topologically-sorted store files))) + (pipe (remote-pipe machine OPEN_WRITE + '("guix" "archive" "--import")))) + (format #t (_ "sending ~a store files to '~a'...~%") + (length files) (build-machine-name machine)) + (catch 'system-error + (lambda () + (export-paths store files pipe)) + (lambda args + (warning (_ "failed while exporting files to '~a': ~a~%") + (build-machine-name machine) + (strerror (system-error-errno args))))) + (zero? (close-pipe pipe)))))) + +(define (retrieve-files files machine) + "Retrieve FILES from MACHINE's store, and import them." + (define host + (build-machine-name machine)) + + (let ((pipe (remote-pipe machine OPEN_READ + `("guix" "archive" "--export" ,@files)))) + (and pipe + (with-store store + (guard (c ((nix-protocol-error? c) + (warning (_ "failed to import files from '~a': ~s~%") + host c) + #f)) + (format (current-error-port) "retrieving ~a files from '~a'...~%" + (length files) host) + + ;; We cannot use the 'import-paths' RPC here because we already + ;; hold the locks for FILES. + (restore-file-set pipe + #:log-port (current-error-port) + #:lock? #f) + + (zero? (close-pipe pipe))))))) + +(define (machine-matches? machine requirements) + "Return #t if MACHINE matches REQUIREMENTS." + (and (string=? (build-requirements-system requirements) + (build-machine-system machine)) + (lset<= string=? + (build-requirements-features requirements) + (build-machine-features machine)))) + +(define (machine-faster? m1 m2) + "Return #t if M1 is faster than M2." + (> (build-machine-speed m1) (build-machine-speed m2))) + +(define (choose-build-machine requirements machines) + "Return the best machine among MACHINES fulfilling REQUIREMENTS, or #f." + ;; FIXME: Take machine load into account, and/or shuffle MACHINES. + (let ((machines (sort (filter (cut machine-matches? <> requirements) + machines) + machine-faster?))) + (match machines + ((head . _) + head) + (_ #f)))) + +(define* (process-request wants-local? system drv features + #:key + print-build-trace? (max-silent-time 3600) + (build-timeout 7200)) + "Process a request to build DRV." + (let* ((local? (and wants-local? (string=? system (%current-system)))) + (reqs (build-requirements + (system system) + (features features))) + (machine (choose-build-machine reqs (build-machines)))) + (if machine + (match (open-ssh-gateway machine) + ((? integer? pid) + (display "# accept\n") + (let ((inputs (string-tokenize (read-line))) + (outputs (string-tokenize (read-line)))) + (when (send-files (cons (derivation-file-name drv) inputs) + machine) + (let ((log (offload drv machine + #:print-build-trace? print-build-trace? + #:max-silent-time max-silent-time + #:build-timeout build-timeout))) + (let loop ((line (read-line log))) + (if (eof-object? line) + (close-pipe log) + (begin + (display line) (newline) + (loop (read-line log)))))) + (retrieve-files outputs machine))) + (format (current-error-port) "done with offloaded '~a'~%" + (derivation-file-name drv)) + (kill pid SIGTERM)) + (#f + (display "# decline\n"))) + (display "# decline\n")))) + +(define-syntax-rule (with-nar-error-handling body ...) + "Execute BODY with any &nar-error suitably reported to the user." + (guard (c ((nar-error? c) + (let ((file (nar-error-file c))) + (if (condition-has-type? c &message) + (leave (_ "while importing file '~a': ~a~%") + file (gettext (condition-message c))) + (leave (_ "failed to import file '~a'~%") + file))))) + body ...)) + + +;;; +;;; Entry point. +;;; + +(define (guix-offload . args) + (define request-line-rx + ;; The request format. See 'tryBuildHook' method in build.cc. + (make-regexp "([01]) ([a-z0-9_-]+) (/[[:graph:]]+.drv) ([[:graph:]]*)")) + + (define not-coma + (char-set-complement (char-set #\,))) + + ;; Make sure $HOME really corresponds to the current user. This is + ;; necessary since lsh uses that to determine the location of the yarrow + ;; seed file, and fails if it's owned by someone else. + (and=> (passwd:dir (getpw (getuid))) + (cut setenv "HOME" <>)) + + (match args + ((system max-silent-time print-build-trace? build-timeout) + (let ((max-silent-time (string->number max-silent-time)) + (build-timeout (string->number build-timeout)) + (print-build-trace? (string=? print-build-trace? "1"))) + (parameterize ((%current-system system)) + (let loop ((line (read-line))) + (unless (eof-object? line) + (cond ((regexp-exec request-line-rx line) + => + (lambda (match) + (with-nar-error-handling + (process-request (equal? (match:substring match 1) "1") + (match:substring match 2) ; system + (call-with-input-file + (match:substring match 3) + read-derivation) + (string-tokenize + (match:substring match 4) not-coma) + #:print-build-trace? print-build-trace? + #:max-silent-time max-silent-time + #:build-timeout build-timeout)))) + (else + (leave (_ "invalid request line: ~s~%") line))) + (loop (read-line))))))) + (("--version") + (show-version-and-exit "guix offload")) + (("--help") + (format #t (_ "Usage: guix offload SYSTEM PRINT-BUILD-TRACE +Process build offload requests written on the standard input, possibly +offloading builds to the machines listed in '~a'.~%") + %machine-file) + (display (_ " +This tool is meant to be used internally by 'guix-daemon'.\n")) + (show-bug-report-information)) + (x + (leave (_ "invalid arguments: ~{~s ~}~%") x)))) + +;;; offload.scm ends here diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 04393abc9a..d41a83de8a 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1032,8 +1032,9 @@ more information.~%")) (('search regexp) (let ((regexp (make-regexp regexp regexp/icase))) - (for-each (cute package->recutils <> (current-output-port)) - (find-packages-by-description regexp)) + (leave-on-EPIPE + (for-each (cute package->recutils <> (current-output-port)) + (find-packages-by-description regexp))) #t)) (('search-paths) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 901b3fb064..3aaa1c4284 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -486,6 +486,29 @@ Internal tool to substitute a pre-built binary to a local build.\n")) "Implement the build daemon's substituter protocol." (mkdir-p %narinfo-cache-directory) (maybe-remove-expired-cached-narinfo) + + ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly + ;; when we know we cannot substitute, but we must emit a newline on stdout + ;; when everything is alright. + (let ((uri (string->uri %cache-url))) + (case (uri-scheme uri) + ((http) + ;; Exit gracefully if there's no network access. + (let ((host (uri-host uri))) + (catch 'getaddrinfo-error + (lambda () + (getaddrinfo host)) + (lambda (key error) + (warning (_ "failed to look up host '~a' (~a), \ +substituter disabled~%") + host (gai-strerror error)) + (exit 0))))) + (else #t))) + + ;; Say hello (see above.) + (newline) + (force-output (current-output-port)) + (with-networking (match args (("--query") diff --git a/guix/store.scm b/guix/store.scm index 1012480b39..eca0de7d97 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -33,6 +33,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 vlist) + #:use-module (ice-9 popen) #:export (%daemon-socket-file nix-server? @@ -52,6 +53,7 @@ open-connection close-connection + with-store set-build-options valid-path? query-path-hash @@ -74,6 +76,7 @@ references requisites referrers + topologically-sorted valid-derivers query-derivation-outputs live-paths @@ -85,6 +88,8 @@ current-build-output-port + register-path + %store-prefix store-path? direct-store-path? @@ -320,6 +325,17 @@ operate, should the disk become full. Return a server object." "Close the connection to SERVER." (close (nix-server-socket server))) +(define-syntax-rule (with-store store exp ...) + "Bind STORE to an open connection to the store and evaluate EXPs; +automatically close the store when the dynamic extent of EXP is left." + (let ((store (open-connection))) + (dynamic-wind + (const #f) + (lambda () + exp ...) + (lambda () + (false-if-exception (close-connection store)))))) + (define current-build-output-port ;; The port where build output is sent. (make-parameter (current-error-port))) @@ -360,11 +376,11 @@ encoding conversion errors." (nix-server-socket server)) ;; magic cookies from worker-protocol.hh - (define %stderr-next #x6f6c6d67) - (define %stderr-read #x64617461) ; data needed from source - (define %stderr-write #x64617416) ; data for sink - (define %stderr-last #x616c7473) - (define %stderr-error #x63787470) + (define %stderr-next #x6f6c6d67) ; "olmg", build log + (define %stderr-read #x64617461) ; "data", data needed from source + (define %stderr-write #x64617416) ; "dat\x16", data for sink + (define %stderr-last #x616c7473) ; "alts", we're done + (define %stderr-error #x63787470) ; "cxtp", error reporting (let ((k (read-int p))) (cond ((= k %stderr-write) @@ -574,6 +590,40 @@ SEED." references, recursively)." (fold-path store cons '() path)) +(define (topologically-sorted store paths) + "Return a list containing PATHS and all their references sorted in +topological order." + (define (traverse) + ;; Do a simple depth-first traversal of all of PATHS. + (let loop ((paths paths) + (visited vlist-null) + (result '())) + (define (visit n) + (vhash-cons n #t visited)) + + (define (visited? n) + (vhash-assoc n visited)) + + (match paths + ((head tail ...) + (if (visited? head) + (loop tail visited result) + (call-with-values + (lambda () + (loop (references store head) + (visit head) + result)) + (lambda (visited result) + (loop tail + visited + (cons head result)))))) + (() + (values visited result))))) + + (call-with-values traverse + (lambda (_ result) + (reverse result)))) + (define referrers (operation (query-referrers (store-path path)) "Return the list of path that refer to PATH." @@ -694,6 +744,28 @@ is true." (and (export-path server head port #:sign? sign?) (loop tail))))))) +(define* (register-path path + #:key (references '()) deriver) + "Register PATH as a valid store file, with REFERENCES as its list of +references, and DERIVER as its deriver (.drv that led to it.) Return #t on +success. + +Use with care as it directly modifies the store! This is primarily meant to +be used internally by the daemon's build hook." + ;; Currently this is implemented by calling out to the fine C++ blob. + (catch 'system-error + (lambda () + (let ((pipe (open-pipe* OPEN_WRITE %guix-register-program))) + (and pipe + (begin + (format pipe "~a~%~a~%~a~%" + path (or deriver "") (length references)) + (for-each (cut format pipe "~a~%" <>) references) + (zero? (close-pipe pipe)))))) + (lambda args + ;; Failed to run %GUIX-REGISTER-PROGRAM. + #f))) + ;;; ;;; Store paths. diff --git a/guix/ui.scm b/guix/ui.scm index f15419f7a8..d6058f806b 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; @@ -138,7 +138,7 @@ messages." "Display version information for COMMAND and `(exit 0)'." (simple-format #t "~a (~a) ~a~%" command %guix-package-name %guix-version) - (display (_ "Copyright (C) 2013 the Guix authors + (display (_ "Copyright (C) 2014 the Guix authors License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html> This is free software: you are free to change and redistribute it. There is NO WARRANTY, to the extent permitted by law. @@ -404,7 +404,11 @@ WIDTH columns." (format port "location: ~a~%" (or (and=> (package-location p) location->string) (_ "unknown"))) - (format port "home-page: ~a~%" (package-home-page p)) + + ;; Note: Starting from version 1.6 or recutils, hyphens are not allowed in + ;; field identifiers. + (format port "homepage: ~a~%" (package-home-page p)) + (format port "license: ~a~%" (match (package-license p) (((? license? licenses) ...) @@ -554,13 +558,17 @@ reporting." (command-files))) (define (show-guix-help) + (define (internal? command) + (member command '("substitute-binary" "authenticate" "offload"))) + (format #t (_ "Usage: guix COMMAND ARGS... Run COMMAND with ARGS.\n")) (newline) (format #t (_ "COMMAND must be one of the sub-commands listed below:\n")) (newline) ;; TODO: Display a synopsis of each command. - (format #t "~{ ~a~%~}" (sort (commands) string<?)) + (format #t "~{ ~a~%~}" (sort (remove internal? (commands)) + string<?)) (show-bug-report-information)) (define program-name diff --git a/guix/utils.scm b/guix/utils.scm index 04a74ee29a..5fda2116de 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -34,7 +34,7 @@ #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 format) - #:autoload (system foreign) (pointer->procedure) + #:use-module (system foreign) #:export (bytevector->base16-string base16-string->bytevector @@ -43,6 +43,7 @@ nixpkgs-derivation* compile-time-value + fcntl-flock memoize default-keyword-arguments substitute-keyword-arguments @@ -224,6 +225,67 @@ buffered data is lost." ;;; +;;; Advisory file locking. +;;; + +(define %struct-flock + ;; 'struct flock' from <fcntl.h>. + (list short ; l_type + short ; l_whence + size_t ; l_start + size_t ; l_len + int)) ; l_pid + +(define F_SETLKW + ;; On Linux-based systems, this is usually 7, but not always + ;; (exceptions include SPARC.) On GNU/Hurd, it's 9. + (compile-time-value + (cond ((string-contains %host-type "sparc") 9) ; sparc-*-linux-gnu + ((string-contains %host-type "linux") 7) ; *-linux-gnu + (else 9)))) ; *-gnu* + +(define F_xxLCK + ;; The F_RDLCK, F_WRLCK, and F_UNLCK constants. + (compile-time-value + (cond ((string-contains %host-type "sparc") #(1 2 3)) ; sparc-*-linux-gnu + ((string-contains %host-type "hppa") #(1 2 3)) ; hppa-*-linux-gnu + ((string-contains %host-type "linux") #(0 1 2)) ; *-linux-gnu + (else #(1 2 3))))) ; *-gnu* + +(define fcntl-flock + (let* ((ptr (dynamic-func "fcntl" (dynamic-link))) + (proc (pointer->procedure int ptr `(,int ,int *)))) + (lambda (fd-or-port operation) + "Perform locking OPERATION on the file beneath FD-OR-PORT. OPERATION +must be a symbol, one of 'read-lock, 'write-lock, or 'unlock." + (define (operation->int op) + (case op + ((read-lock) (vector-ref F_xxLCK 0)) + ((write-lock) (vector-ref F_xxLCK 1)) + ((unlock) (vector-ref F_xxLCK 2)) + (else (error "invalid fcntl-flock operation" op)))) + + (define fd + (if (port? fd-or-port) + (fileno fd-or-port) + fd-or-port)) + + ;; XXX: 'fcntl' is a vararg function, but here we happily use the + ;; standard ABI; crossing fingers. + (let ((err (proc fd + F_SETLKW ; lock & wait + (make-c-struct %struct-flock + (list (operation->int operation) + SEEK_SET + 0 0 ; whole file + 0))))) + (or (zero? err) + + ;; Presumably we got EAGAIN or so. + (throw 'flock-error fd)))))) + + +;;; ;;; Miscellaneous. ;;; |