From 8fa3e6b338fa9e2534ea971269ac2d3ed49a305b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 13 Jan 2014 18:49:26 +0100 Subject: ui: Don't use hyphens in 'package->recutils' output. * guix/ui.scm (package->recutils): Rename recutils field from 'home-page' to 'homepage'. --- guix/ui.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index f15419f7a8..2b1a5af199 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 +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; Copyright © 2013 Mark H Weaver ;;; Copyright © 2013 Nikita Karetnikov ;;; @@ -404,7 +404,11 @@ (define (description->recutils str) (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) ...) -- cgit v1.2.3 From eb9a9feefdcf1ea602468fa6fbbfa1ea0539dee9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 13 Jan 2014 18:51:07 +0100 Subject: guix package: Gracefully handle EPIPE on '--search'. * guix/scripts/package.scm (guix-package): Wrap body of 'search' in 'leave-on-EPIPE'. --- guix/scripts/package.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') 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 @@ (define (list-generation number) (('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) -- cgit v1.2.3 From c5e0eb28845dc1f01ab5b4e81ee6596a23223ede Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 17 Jan 2014 22:49:42 +0100 Subject: ui: Update copyright year in '--version' output. * guix/ui.scm (show-version-and-exit): Increment copyright year. --- guix/ui.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 2b1a5af199..041887e7f0 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -138,7 +138,7 @@ (define* (show-version-and-exit #:optional (command (car (command-line)))) "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 This is free software: you are free to change and redistribute it. There is NO WARRANTY, to the extent permitted by law. -- cgit v1.2.3 From b97c95eb3c4894bbbe7b645b163147e3f837e754 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 18 Jan 2014 15:08:33 +0100 Subject: linux-initrd: Make /dev/{null,zero} world-writable. Reported by zerwas on #guix. * guix/build/linux-initrd.scm (make-essential-device-nodes): Make /dev/null and /dev/zero world-writable. --- guix/build/linux-initrd.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -95,7 +95,9 @@ (define (scope dir) ;; 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")) -- cgit v1.2.3 From d43eb499a6c112af609118803c6cd33fbcedfa43 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 18 Jan 2014 16:48:29 +0100 Subject: Update 'nix-upstream' sub-module; adjust build system, doc, and substituter. * nix-upstream: Update sub-module. * daemon.am (libutil_a_SOURCES): Add affinity.cc. (libutil_headers): Add affinity.hh. (libexec_PROGRAMS, nix_setuid_helper_SOURCES, nix_setuid_helper_CPPFLAGS, nix_setuid_helper_LDADD): Remove. * doc/guix.texi (Setting Up the Daemon): Remove paragraph about 'nix-setuid-helper'. * guix/scripts/substitute-binary.scm (guix-substitute-binary): Exit 0 when %CACHE-URL has an HTTP scheme and looking up its host fails. Always print a newline to stdout when starting. --- daemon.am | 14 +++----------- doc/guix.texi | 16 +--------------- guix/scripts/substitute-binary.scm | 25 ++++++++++++++++++++++++- nix-upstream | 2 +- 4 files changed, 29 insertions(+), 28 deletions(-) (limited to 'guix') diff --git a/daemon.am b/daemon.am index 60bbaf73ed..f4700f0b07 100644 --- a/daemon.am +++ b/daemon.am @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013 Ludovic Courtès +# Copyright © 2012, 2013, 2014 Ludovic Courtès # # This file is part of GNU Guix. # @@ -56,6 +56,7 @@ libformat_a_CPPFLAGS = \ libutil_a_SOURCES = \ nix/libutil/archive.cc \ + nix/libutil/affinity.cc \ nix/libutil/serialise.cc \ nix/libutil/util.cc \ nix/libutil/xml-writer.cc \ @@ -63,6 +64,7 @@ libutil_a_SOURCES = \ nix/libutil/gcrypt-hash.cc libutil_headers = \ + nix/libutil/affinity.hh \ nix/libutil/hash.hh \ nix/libutil/serialise.hh \ nix/libutil/xml-writer.hh \ @@ -153,16 +155,6 @@ guix_register_LDADD = \ $(SQLITE3_LIBS) $(LIBGCRYPT_LIBS) -libexec_PROGRAMS = nix-setuid-helper -nix_setuid_helper_SOURCES = \ - nix/nix-setuid-helper/nix-setuid-helper.cc - -nix_setuid_helper_CPPFLAGS = \ - $(libutil_a_CPPFLAGS) - -nix_setuid_helper_LDADD = \ - libutil.a libformat.a - noinst_HEADERS = \ $(libformat_headers) $(libutil_headers) $(libstore_headers) \ $(guix_daemon_headers) diff --git a/doc/guix.texi b/doc/guix.texi index 2081dd13ad..2c40fa83f3 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -245,21 +245,7 @@ archive}): # guix archive --generate-key @end example -Guix may also be used in a single-user setup, with @command{guix-daemon} -running as an unprivileged user. However, to maximize non-interference -of build processes, the daemon still needs to perform certain operations -that are restricted to @code{root} on GNU/Linux: it should be able to -run build processes in a chroot, and to run them under different UIDs. -To that end, the @command{nix-setuid-helper} program is provided; it is -a small C program (less than 300 lines) that, if it is made setuid -@code{root}, can be executed by the daemon to perform these operations -on its behalf. The @code{root}-owned @file{/etc/nix-setuid.conf} file -is read by @command{nix-setuid-helper}; it should contain exactly two -words: the user name under which the authorized @command{guix-daemon} -runs, and the name of the build users group. - -If you are installing Guix as an unprivileged user and do not have the -ability to make @file{nix-setuid-helper} setuid-@code{root}, it is still +If you are installing Guix as an unprivileged user, it is still possible to run @command{guix-daemon}. However, build processes will not be isolated from one another, and not from the rest of the system. Thus, build processes may interfere with each other, and may access 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 +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -486,6 +486,29 @@ (define (guix-substitute-binary . args) "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/nix-upstream b/nix-upstream index 1b6ee8f4c7..bf0ad8aabc 160000 --- a/nix-upstream +++ b/nix-upstream @@ -1 +1 @@ -Subproject commit 1b6ee8f4c7e74f75e1f49b43cf22be7730b30649 +Subproject commit bf0ad8aabca67b4faabe3a1ac3c57884ae9924f4 -- cgit v1.2.3 From 66ea671393c76db3e97aacde40273f11fcf8c337 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Jan 2014 00:20:40 +0100 Subject: licenses: Add GNU FDL 1.3+. * guix/licenses.scm (fdl1.3+): New variable. --- guix/licenses.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'guix') 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 +;;; Copyright © 2012, 2014 Ludovic Courtès ;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2012, 2013 Nikita Karetnikov ;;; @@ -31,6 +31,7 @@ (define-module (guix licenses) expat freetype gpl1 gpl1+ gpl2 gpl2+ gpl3 gpl3+ + fdl1.3+ isc ijg ibmpl1.0 @@ -161,6 +162,11 @@ (define gpl3+ "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" -- cgit v1.2.3 From 59f734f351ee1703dca3e7e01150b52517d48849 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 6 Jan 2014 23:31:17 +0100 Subject: ui: Filter out internal commands from '--help'. * guix/ui.scm (show-guix-help)[internal?]: New procedure. Use it to filter out internal commands reported by '--help'. --- guix/ui.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 041887e7f0..bb811c557d 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -558,13 +558,17 @@ (define (commands) (command-files))) (define (show-guix-help) + (define (internal? command) + (member command '("substitute-binary" "authenticate"))) + (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 Date: Thu, 9 Jan 2014 23:59:07 +0100 Subject: store: Add comments for the %stderr constants. * guix/store.scm (process-stderr): Add comments for the various constants, to help when stracing. --- guix/store.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 1012480b39..8ad32b2fd5 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -360,11 +360,11 @@ (define p (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) -- cgit v1.2.3 From 6bfec3edf52ed6145c3c89fb19d350498dd2b758 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 11 Jan 2014 17:11:14 +0100 Subject: store: Add 'register-path' procedure. * guix/store.scm (register-path): New procedure. * tests/store.scm ("register-path"): New test. * guix/config.scm.in (%guix-register-program): New variable. * configure.ac: Compute and substitute 'guix_sbindir'. Compute 'guix_prefix'. * pre-inst-env.in: Define 'GUIX_REGISTER'. --- configure.ac | 7 +++++-- guix/config.scm.in | 5 +++++ guix/store.scm | 25 +++++++++++++++++++++++++ pre-inst-env.in | 4 ++++ tests/store.scm | 22 +++++++++++++++++++++- 5 files changed, 60 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/configure.ac b/configure.ac index 799b3e8152..749672f15b 100644 --- a/configure.ac +++ b/configure.ac @@ -38,10 +38,13 @@ AC_ARG_ENABLE([daemon], # Prepare a version of $localstatedir & co. that does not contain references # to shell variables. -guix_localstatedir="`eval echo $localstatedir | sed -e "s|NONE|/usr/local|g"`" -guix_sysconfdir="`eval echo $sysconfdir | sed -e "s|NONE|/usr/local|g"`" +guix_prefix="`eval echo $prefix | sed -e"s|NONE|/usr/local|g"`" +guix_localstatedir="`eval echo $localstatedir | sed -e "s|NONE|$guix_prefix|g"`" +guix_sysconfdir="`eval echo $sysconfdir | sed -e "s|NONE|$guix_prefix|g"`" +guix_sbindir="`eval echo $sbindir | sed -e "s|NONE|$guix_prefix|g"`" AC_SUBST([guix_localstatedir]) AC_SUBST([guix_sysconfdir]) +AC_SUBST([guix_sbindir]) dnl We require the pkg.m4 set of macros from pkg-config. dnl Make sure it's available. 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 @@ (define-module (guix config) %store-directory %state-directory %config-directory + %guix-register-program %system %libgcrypt %nixpkgs @@ -62,6 +63,10 @@ (define %config-directory ;; 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/store.scm b/guix/store.scm index 8ad32b2fd5..393eee8d1b 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -33,6 +33,7 @@ (define-module (guix store) #: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? @@ -85,6 +86,8 @@ (define-module (guix store) current-build-output-port + register-path + %store-prefix store-path? direct-store-path? @@ -694,6 +697,28 @@ (define* (export-paths server paths port #:key (sign? #t)) (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/pre-inst-env.in b/pre-inst-env.in index acdce61168..3f1fa59bb8 100644 --- a/pre-inst-env.in +++ b/pre-inst-env.in @@ -46,6 +46,10 @@ 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 NIX_SUBSTITUTERS +# The 'guix-register' program. +GUIX_REGISTER="$abs_top_builddir/guix-register" +export GUIX_REGISTER + # The following variables need only be defined when compiling Guix # modules, but we define them to be on the safe side in case of # auto-compilation. diff --git a/tests/store.scm b/tests/store.scm index 4bd739e7f6..5ae036c060 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -389,6 +389,26 @@ (define (same? x y) (pk 'corrupt-imported imported) #f))))) +(test-assert "register-path" + (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f) + "-fake"))) + (when (valid-path? %store file) + (delete-paths %store (list file))) + (false-if-exception (delete-file file)) + + (let ((ref (add-text-to-store %store "ref-of-fake" (random-text))) + (drv (string-append file ".drv"))) + (call-with-output-file file + (cut display "This is a fake store item.\n" <>)) + (register-path file + #:references (list ref) + #:deriver drv) + + (and (valid-path? %store file) + (equal? (references %store file) (list ref)) + (null? (valid-derivers %store file)) + (null? (referrers %store file)))))) + (test-end "store") -- cgit v1.2.3 From 2cd5c0380ed36f334114904bacf9562fc98e2090 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 10 Jan 2014 23:27:39 +0100 Subject: utils: Add 'fcntl-flock'. * guix/utils.scm (%struct-flock, F_SETLKW, F_xxLCK): New variables. (fcntl-flock): New procedure. * tests/utils.scm ("fcntl-flock"): New test. --- guix/utils.scm | 66 +++++++++++++++++++++++++++++++++++++++++++++++++++++++-- tests/utils.scm | 32 +++++++++++++++++++++++++++- 2 files changed, 95 insertions(+), 3 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; Copyright © 2013 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -34,7 +34,7 @@ (define-module (guix utils) #: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 @@ (define-module (guix utils) nixpkgs-derivation* compile-time-value + fcntl-flock memoize default-keyword-arguments substitute-keyword-arguments @@ -222,6 +223,67 @@ (define-syntax-rule (nixpkgs-derivation* attribute) "Evaluate the given Nixpkgs derivation at compile-time." (compile-time-value (nixpkgs-derivation attribute))) + +;;; +;;; Advisory file locking. +;;; + +(define %struct-flock + ;; 'struct flock' from . + (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. diff --git a/tests/utils.scm b/tests/utils.scm index 017d9170fa..b5706aa792 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -139,6 +139,36 @@ (define-module (test-utils) (append pids1 pids2))) (equal? (get-bytevector-all decompressed) data))))) +(test-equal "fcntl-flock" + 0 ; the child's exit status + (let ((file (open-input-file (search-path %load-path "guix.scm")))) + (fcntl-flock file 'read-lock) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + ;; Taking a read lock should be OK. + (fcntl-flock file 'read-lock) + (fcntl-flock file 'unlock) + + (catch 'flock-error + (lambda () + ;; Taking an exclusive lock should raise an exception. + (fcntl-flock file 'write-lock)) + (lambda args + (primitive-exit 0))) + (primitive-exit 1)) + (lambda () + (primitive-exit 2)))) + (pid + (match (waitpid pid) + ((_ . status) + (let ((result (status:exit-val status))) + (fcntl-flock file 'unlock) + (close-port file) + result))))))) + ;; This is actually in (guix store). (test-equal "store-path-package-name" "bash-4.2-p24" -- cgit v1.2.3 From d28684b5a5369ac87b0a2d3ae125a54d74826a2e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 23 Jan 2014 22:23:22 +0100 Subject: pki: Factorize signature manipulation procedures. * guix/pki.scm (signature-subject, signature-signed-data, valid-signature?): New procedures. * guix/scripts/authenticate.scm (guix-authenticate): Adjust to use them. --- guix/pki.scm | 23 ++++++++++++++++++++++- guix/scripts/authenticate.scm | 24 +++++++++++------------- 2 files changed, 33 insertions(+), 14 deletions(-) (limited to 'guix') 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 @@ (define-module (guix pki) 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 @@ (define (signature-sexp data secret-key public-key) (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/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 +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -72,23 +72,21 @@ (define (guix-authenticate . args) ;; 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 -- cgit v1.2.3 From 045111e10c0197f1a235bb886df2e446285a6f70 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 19 Jan 2014 18:16:28 +0100 Subject: hash: Add 'open-sha256-input-port', for Guile > 2.0.9. * guix/hash.scm (open-sha256-input-port): New procedure. * tests/hash.scm (supports-unbuffered-cbip?): New procedure. ("open-sha256-input-port, empty", "open-sha256-input-port, hello", "open-sha256-input-port, hello, one two", "open-sha256-input-port, hello, read from wrapped port"): New tests. --- guix/hash.scm | 42 +++++++++++++++++++++++++++++++++++++++-- tests/hash.scm | 59 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 98 insertions(+), 3 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,7 +25,8 @@ (define-module (guix hash) #:use-module (srfi srfi-11) #:export (sha256 open-sha256-port - port-sha256)) + port-sha256 + open-sha256-input-port)) ;;; Commentary: ;;; @@ -128,4 +129,41 @@ (define (port-sha256 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/tests/hash.scm b/tests/hash.scm index 27751023d3..9bcd69440b 100644 --- a/tests/hash.scm +++ b/tests/hash.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013 Ludovic Courtès +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -37,6 +37,14 @@ (define %hello-sha256 (base16-string->bytevector "b94d27b9934d3e08a52e52d7da7dabfac484efe37a5380ee9088f7ace2efcde9")) +(define (supports-unbuffered-cbip?) + "Return #t if unbuffered custom binary input ports (CBIPs) are supported. +In Guile <= 2.0.9, CBIPs were always fully buffered, so the +'open-sha256-input-port' does not work there." + (false-if-exception + (setvbuf (make-custom-binary-input-port "foo" pk #f #f #f) _IONBF))) + + (test-begin "hash") (test-equal "sha256, empty" @@ -68,6 +76,55 @@ (define %hello-sha256 (equal? (sha256 contents) (call-with-input-file file port-sha256)))) +(test-skip (if (supports-unbuffered-cbip?) 0 4)) + +(test-equal "open-sha256-input-port, empty" + `("" ,%empty-sha256) + (let-values (((port get) + (open-sha256-input-port (open-string-input-port "")))) + (let ((str (get-string-all port))) + (list str (get))))) + +(test-equal "open-sha256-input-port, hello" + `("hello world" ,%hello-sha256) + (let-values (((port get) + (open-sha256-input-port + (open-bytevector-input-port + (string->utf8 "hello world"))))) + (let ((str (get-string-all port))) + (list str (get))))) + +(test-equal "open-sha256-input-port, hello, one two" + (list (string->utf8 "hel") (string->utf8 "lo") + (base16-string->bytevector ; echo -n hello | sha256sum + "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824") + " world") + (let-values (((port get) + (open-sha256-input-port + (open-bytevector-input-port (string->utf8 "hello world"))))) + (let* ((one (get-bytevector-n port 3)) + (two (get-bytevector-n port 2)) + (hash (get)) + (three (get-string-all port))) + (list one two hash three)))) + +(test-equal "open-sha256-input-port, hello, read from wrapped port" + (list (string->utf8 "hello") + (base16-string->bytevector ; echo -n hello | sha256sum + "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824") + " world") + (let*-values (((wrapped) + (open-bytevector-input-port (string->utf8 "hello world"))) + ((port get) + (open-sha256-input-port wrapped))) + (let* ((hello (get-bytevector-n port 5)) + (hash (get)) + + ;; Now read from WRAPPED to make sure its current position is + ;; correct. + (world (get-string-all wrapped))) + (list hello hash world)))) + (test-end) -- cgit v1.2.3 From ce4a482983abaf7090d098cdda973139cefb56b7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 19 Jan 2014 23:03:43 +0100 Subject: store: Add 'with-store' convenience macro. * guix/store.scm (with-store): New macro. --- .dir-locals.el | 1 + guix/store.scm | 12 ++++++++++++ 2 files changed, 13 insertions(+) (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index 87cdaae807..03d9a4ec8d 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -18,6 +18,7 @@ (eval . (put 'manifest-entry 'scheme-indent-function 0)) (eval . (put 'manifest-pattern 'scheme-indent-function 0)) (eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1)) + (eval . (put 'with-store 'scheme-indent-function 1)) (eval . (put 'with-error-handling 'scheme-indent-function 0)) (eval . (put 'with-mutex 'scheme-indent-function 1)) (eval . (put 'with-atomic-file-output 'scheme-indent-function 1)) diff --git a/guix/store.scm b/guix/store.scm index 393eee8d1b..ede64341c5 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -53,6 +53,7 @@ (define-module (guix store) open-connection close-connection + with-store set-build-options valid-path? query-path-hash @@ -323,6 +324,17 @@ (define (close-connection server) "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))) -- cgit v1.2.3 From cd4027fa478e20b59e798dd163a54e7ff9c42c98 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Jan 2014 17:09:21 +0100 Subject: nar: Add 'restore-file-set', for use by build hooks. * guix/nar.scm (&nar-invalid-hash-error, &nar-signature-error): New condition types. (&nar-error): Add 'file' and 'port' fields. (&nar-read-error): Remove 'port' and 'file' fields. (lock-store-file, unlock-store-file, finalize-store-file, temporary-store-directory, restore-file-set): New procedures. * tests/nar.scm (%seed): New variable. (random-text): New procedure. ("restore-file-set (signed, valid)", "restore-file-set (missing signature)", "restore-file-set (corrupt)"): New tests. * po/Makevars (XGETTEXT_OPTIONS): Add '--keyword=message'.nar fixes * po/POTFILES.in: Add guix/nar.scm. --- guix/nar.scm | 229 +++++++++++++++++++++++++++++++++++++++++++++++++++++++-- po/Makevars | 13 ++-- po/POTFILES.in | 1 + tests/nar.scm | 103 +++++++++++++++++++++++++- 4 files changed, 332 insertions(+), 14 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; ;;; 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 @@ (define-module (guix nar) ;;; 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 @@ (define (read-eof-marker) (&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/po/Makevars b/po/Makevars index 81fd53ef2c..ade615a452 100644 --- a/po/Makevars +++ b/po/Makevars @@ -5,11 +5,14 @@ DOMAIN = $(PACKAGE) subdir = po top_builddir = .. -# These options get passed to xgettext. -XGETTEXT_OPTIONS = \ - --language=Scheme --from-code=UTF-8 \ - --keyword=_ --keyword=N_ \ - --keyword=synopsis --keyword=description +# These options get passed to xgettext. We want to catch standard +# gettext uses, package synopses and descriptions, and SRFI-34 error +# condition messages. +XGETTEXT_OPTIONS = \ + --language=Scheme --from-code=UTF-8 \ + --keyword=_ --keyword=N_ \ + --keyword=synopsis --keyword=description \ + --keyword=message COPYRIGHT_HOLDER = Ludovic Courtès diff --git a/po/POTFILES.in b/po/POTFILES.in index beefdc901b..b329f21e92 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -15,3 +15,4 @@ guix/scripts/authenticate.scm guix/gnu-maintenance.scm guix/ui.scm guix/http-client.scm +guix/nar.scm diff --git a/tests/nar.scm b/tests/nar.scm index 6493d76876..9f21f990c8 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,11 +18,17 @@ (define-module (test-nar) #:use-module (guix nar) + #:use-module (guix store) + #:use-module ((guix hash) #:select (open-sha256-input-port)) #: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 (srfi srfi-64) #:use-module (ice-9 ftw) + #:use-module (ice-9 regex) #:use-module (ice-9 match)) ;; Test the (guix nar) module. @@ -156,6 +162,24 @@ (define %test-dir (string-append (dirname (search-path %load-path "pre-inst-env")) "/test-nar-" (number->string (getpid)))) +;; XXX: Factorize. +(define %seed + (seed->random-state (logxor (getpid) (car (gettimeofday))))) + +(define (random-text) + (number->string (random (expt 2 256) %seed) 16)) + +(define-syntax-rule (let/ec k exp...) + ;; This one appeared in Guile 2.0.9, so provide a copy here. + (let ((tag (make-prompt-tag))) + (call-with-prompt tag + (lambda () + (let ((k (lambda args + (apply abort-to-prompt tag args)))) + exp...)) + (lambda (_ . args) + (apply values args))))) + (test-begin "nar") @@ -201,6 +225,83 @@ (define %test-dir (lambda () (rmdir input))))) +;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn +;; relies on a Guile 2.0.10+ feature. +(test-skip (if (false-if-exception + (open-sha256-input-port (%make-void-port "r"))) + 0 + 3)) + +(test-assert "restore-file-set (signed, valid)" + (with-store store + (let* ((texts (unfold (cut >= <> 10) + (lambda _ (random-text)) + 1+ + 0)) + (files (map (cut add-text-to-store store "text" <>) texts)) + (dump (call-with-bytevector-output-port + (cut export-paths store files <>)))) + (delete-paths store files) + (and (every (negate file-exists?) files) + (let* ((source (open-bytevector-input-port dump)) + (imported (restore-file-set source))) + (and (equal? imported files) + (every (lambda (file) + (and (file-exists? file) + (valid-path? store file))) + files) + (equal? texts + (map (lambda (file) + (call-with-input-file file + get-string-all)) + files)))))))) + +(test-assert "restore-file-set (missing signature)" + (let/ec return + (with-store store + (let* ((file (add-text-to-store store "foo" "Hello, world!")) + (dump (call-with-bytevector-output-port + (cute export-paths store (list file) <> + #:sign? #f)))) + (delete-paths store (list file)) + (and (not (file-exists? file)) + (let ((source (open-bytevector-input-port dump))) + (guard (c ((nar-signature-error? c) + (let ((message (condition-message c)) + (port (nar-error-port c))) + (return + (and (string-match "lacks.*signature" message) + (string=? file (nar-error-file c)) + (eq? source port)))))) + (restore-file-set source)) + #f)))))) + +(test-assert "restore-file-set (corrupt)" + (let/ec return + (with-store store + (let* ((file (add-text-to-store store "foo" + (random-text))) + (dump (call-with-bytevector-output-port + (cute export-paths store (list file) <>)))) + (delete-paths store (list file)) + + ;; Flip a byte in the file contents. + (let* ((index 120) + (byte (bytevector-u8-ref dump index))) + (bytevector-u8-set! dump index (logxor #xff byte))) + + (and (not (file-exists? file)) + (let ((source (open-bytevector-input-port dump))) + (guard (c ((nar-invalid-hash-error? c) + (let ((message (condition-message c)) + (port (nar-error-port c))) + (return + (and (string-contains message "hash") + (string=? file (nar-error-file c)) + (eq? source port)))))) + (restore-file-set source)) + #f)))))) + (test-end "nar") -- cgit v1.2.3 From 50add47748eb40371d8b88208a13e7230d15c220 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 23 Jan 2014 22:13:27 +0100 Subject: store: Add 'topologically-sorted'. * guix/store.scm (topologically-sorted): New procedure. * tests/store.scm ("topologically-sorted, one item", "topologically-sorted, several items", "topologically-sorted, more difficult"): New tests. --- guix/store.scm | 35 +++++++++++++++++++++++++++++++++++ tests/store.scm | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 67 insertions(+) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index ede64341c5..eca0de7d97 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -76,6 +76,7 @@ (define-module (guix store) references requisites referrers + topologically-sorted valid-derivers query-derivation-outputs live-paths @@ -589,6 +590,40 @@ (define (requisites store path) 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." diff --git a/tests/store.scm b/tests/store.scm index 5ae036c060..a61d449fb4 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -162,6 +162,38 @@ (define (same? x y) (equal? (valid-derivers %store o) (list (derivation-file-name d)))))) +(test-assert "topologically-sorted, one item" + (let* ((a (add-text-to-store %store "a" "a")) + (b (add-text-to-store %store "b" "b" (list a))) + (c (add-text-to-store %store "c" "c" (list b))) + (d (add-text-to-store %store "d" "d" (list c))) + (s (topologically-sorted %store (list d)))) + (equal? s (list a b c d)))) + +(test-assert "topologically-sorted, several items" + (let* ((a (add-text-to-store %store "a" "a")) + (b (add-text-to-store %store "b" "b" (list a))) + (c (add-text-to-store %store "c" "c" (list b))) + (d (add-text-to-store %store "d" "d" (list c))) + (s1 (topologically-sorted %store (list d a c b))) + (s2 (topologically-sorted %store (list b d c a b d)))) + (equal? s1 s2 (list a b c d)))) + +(test-assert "topologically-sorted, more difficult" + (let* ((a (add-text-to-store %store "a" "a")) + (b (add-text-to-store %store "b" "b" (list a))) + (c (add-text-to-store %store "c" "c" (list b))) + (d (add-text-to-store %store "d" "d" (list c))) + (w (add-text-to-store %store "w" "w")) + (x (add-text-to-store %store "x" "x" (list w))) + (y (add-text-to-store %store "y" "y" (list x d))) + (s1 (topologically-sorted %store (list y))) + (s2 (topologically-sorted %store (list c y))) + (s3 (topologically-sorted %store (cons y (references %store y))))) + (and (equal? s1 (list w x a b c d y)) + (equal? s2 (list a b c w x d y)) + (lset= string=? s1 s3)))) + (test-assert "log-file, derivation" (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) (s (add-to-store %store "bash" #t "sha256" -- cgit v1.2.3 From 49e6291a7a257f89f01644423f1b685778b8862a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 23 Jan 2014 23:48:34 +0100 Subject: Add 'guix offload' as a daemon build hook. * nix/nix-daemon/guix-daemon.cc (GUIX_OPT_NO_BUILD_HOOK): New macro. (options): Add '--no-build-hook'. (parse_opt): Handle it. (main)[HAVE_DAEMON_OFFLOAD_HOOK]: Set 'useBuildHook' by default. Set $NIX_BUILD_HOOK to our offload hook unless otherwise specified. [!HAVE_DAEMON_OFFLOAD_HOOK]: Clear 'useBuildHook'. * pre-inst-env.in: Set and export NIX_BUILD_HOOK. * nix/scripts/offload.in, guix/scripts/offload.scm: New files. * guix/ui.scm (show-guix-help)[internal?]: Add "offload". * config-daemon.ac: Call 'GUIX_CHECK_UNBUFFERED_CBIP'. Instantiate 'nix/scripts/offload'. Set 'BUILD_DAEMON_OFFLOAD' conditional, and optionally define 'HAVE_DEAMON_OFFLOAD_HOOK' cpp macro. * daemon.am (nodist_pkglibexec_SCRIPTS)[BUILD_DAEMON_OFFLOAD]: Add it. * Makefile.am (MODULES)[BUILD_DAEMON_OFFLOAD]: Add 'guix/scripts/offload.scm'. (EXTRA_DIST)[!BUILD_DAEMON_OFFLOAD]: Likewise. * m4/guix.m4 (GUIX_CHECK_UNBUFFERED_CBIP): New macro. * doc/guix.texi (Setting Up the Daemon): Move most of the body to... (Build Environment Setup): ... this. New subsection. (Daemon Offload Setup): New subsection. --- .gitignore | 1 + Makefile.am | 17 +- config-daemon.ac | 16 ++ daemon.am | 8 + doc/guix.texi | 122 +++++++++++++- guix/scripts/offload.scm | 380 ++++++++++++++++++++++++++++++++++++++++++ guix/ui.scm | 2 +- m4/guix.m4 | 19 ++- nix/nix-daemon/guix-daemon.cc | 23 ++- nix/scripts/offload.in | 11 ++ pre-inst-env.in | 5 +- 11 files changed, 589 insertions(+), 15 deletions(-) create mode 100644 guix/scripts/offload.scm create mode 100644 nix/scripts/offload.in (limited to 'guix') diff --git a/.gitignore b/.gitignore index 09a593e9fa..10b18daa5e 100644 --- a/.gitignore +++ b/.gitignore @@ -85,3 +85,4 @@ GRTAGS GTAGS /nix-setuid-helper /nix/scripts/guix-authenticate +/nix/scripts/offload diff --git a/Makefile.am b/Makefile.am index 6d6aba059b..16b28eb181 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013 Ludovic Courtès +# Copyright © 2012, 2013, 2014 Ludovic Courtès # Copyright © 2013 Andreas Enge # # This file is part of GNU Guix. @@ -80,6 +80,13 @@ MODULES = \ guix.scm \ $(GNU_SYSTEM_MODULES) +if BUILD_DAEMON_OFFLOAD + +MODULES += \ + guix/scripts/offload.scm + +endif BUILD_DAEMON_OFFLOAD + # Because of the autoload hack in (guix build download), we must build it # first to avoid errors on systems where (gnutls) is unavailable. guix/scripts/download.go: guix/build/download.go @@ -185,6 +192,14 @@ EXTRA_DIST = \ release.nix \ $(TESTS) +if !BUILD_DAEMON_OFFLOAD + +EXTRA_DIST += \ + guix/scripts/offload.scm + +endif !BUILD_DAEMON_OFFLOAD + + CLEANFILES = \ $(GOBJECTS) \ $(SCM_TESTS:tests/%.scm=%.log) diff --git a/config-daemon.ac b/config-daemon.ac index 0717141198..1169bb6ef4 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -95,6 +95,17 @@ if test "x$guix_build_daemon" = "xyes"; then dnl Check for (for immutable file support). AC_CHECK_HEADERS([linux/fs.h]) + dnl Check whether the 'offload' build hook can be built (uses + dnl 'restore-file-set', which requires unbuffered custom binary input + dnl ports from Guile >= 2.0.10.) + GUIX_CHECK_UNBUFFERED_CBIP + guix_build_daemon_offload="$ac_cv_guix_cbips_support_setvbuf" + + if test "x$guix_build_daemon_offload" = "xyes"; then + AC_DEFINE([HAVE_DAEMON_OFFLOAD_HOOK], [1], + [Define if the daemon's 'offload' build hook is being built.]) + fi + dnl Temporary directory used to store the daemon's data. AC_MSG_CHECKING([for unit test root]) GUIX_TEST_ROOT="`pwd`/test-tmp" @@ -107,6 +118,11 @@ if test "x$guix_build_daemon" = "xyes"; then [chmod +x nix/scripts/substitute-binary]) AC_CONFIG_FILES([nix/scripts/guix-authenticate], [chmod +x nix/scripts/guix-authenticate]) + AC_CONFIG_FILES([nix/scripts/offload], + [chmod +x nix/scripts/offload]) fi AM_CONDITIONAL([BUILD_DAEMON], [test "x$guix_build_daemon" = "xyes"]) +AM_CONDITIONAL([BUILD_DAEMON_OFFLOAD], \ + [test "x$guix_build_daemon" = "xyes" \ + && test "x$guix_build_daemon_offload" = "xyes"]) diff --git a/daemon.am b/daemon.am index f4700f0b07..1059e444ab 100644 --- a/daemon.am +++ b/daemon.am @@ -172,6 +172,14 @@ nodist_pkglibexec_SCRIPTS = \ nix/scripts/list-runtime-roots \ nix/scripts/substitute-binary +if BUILD_DAEMON_OFFLOAD + +nodist_pkglibexec_SCRIPTS += \ + nix/scripts/offload + +endif BUILD_DAEMON_OFFLOAD + + # XXX: It'd be better to hide it in $(pkglibexecdir). nodist_libexec_SCRIPTS = \ nix/scripts/guix-authenticate diff --git a/doc/guix.texi b/doc/guix.texi index a637614fbb..48e4631836 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -175,13 +175,24 @@ your goal is to share the store with Nix. @cindex daemon Operations such as building a package or running the garbage collector -are all performed by a specialized process, the @dfn{Guix daemon}, on +are all performed by a specialized process, the @dfn{build daemon}, on behalf of clients. Only the daemon may access the store and its associated database. Thus, any operation that manipulates the store goes through the daemon. For instance, command-line tools such as @command{guix package} and @command{guix build} communicate with the daemon (@i{via} remote procedure calls) to instruct it what to do. +The following sections explain how to prepare the build daemon's +environment. + +@menu +* Build Environment Setup:: Preparing the isolated build environment. +* Daemon Offload Setup:: Offloading builds to remote machines. +@end menu + +@node Build Environment Setup +@subsection Build Environment Setup + In a standard multi-user setup, Guix and its daemon---the @command{guix-daemon} program---are installed by the system administrator; @file{/nix/store} is owned by @code{root} and @@ -256,14 +267,6 @@ user @file{nobody}; a writable @file{/tmp} directory. @end itemize -Finally, you may want to generate a key pair to allow the daemon to -export signed archives of files from the store (@pxref{Invoking guix -archive}): - -@example -# guix archive --generate-key -@end example - If you are installing Guix as an unprivileged user, it is still possible to run @command{guix-daemon}. However, build processes will not be isolated from one another, and not from the rest of the system. @@ -271,6 +274,107 @@ Thus, build processes may interfere with each other, and may access programs, libraries, and other files available on the system---making it much harder to view them as @emph{pure} functions. + +@node Daemon Offload Setup +@subsection Using the Offload Facility + +@cindex offloading +The build daemon can @dfn{offload} derivation builds to other machines +running Guix, using the @code{offload} @dfn{build hook}. When that +feature is enabled, a list of user-specified build machines is read from +@file{/etc/guix/machines.scm}; anytime a build is requested, for +instance via @code{guix build}, the daemon attempts to offload it to one +of the machines that satisfies the derivation's constraints, in +particular its system type---e.g., @file{x86_64-linux}. Missing +prerequisites for the build are copied over SSH to the target machine, +which then proceeds with the build; upon success the output(s) of the +build are copied back to the initial machine. + +The @file{/etc/guix/machines.scm} is---not surprisingly!---a Scheme file +whose return value must be a list of @code{build-machine} objects. In +practice, it typically looks like this: + +@example +(list (build-machine + (name "eightysix.example.org") + (system "x86_64-linux") + (user "bob") + (speed 2.)) ; incredibly fast! + + (build-machine + (name "meeps.example.org") + (system "mips64el-linux") + (user "alice") + (private-key + (string-append (getenv "HOME") + "/.ssh/id-rsa-for-guix")))) +@end example + +@noindent +In the example above we specify a list of two build machines, one for +the @code{x86_64} architecture and one for the @code{mips64el} +architecture. The compulsory fields for a @code{build-machine} +declaration are: + +@table @code + +@item name +The remote machine's host name. + +@item system +The remote machine's system type. + +@item user +The user account to use when connecting to the remote machine over SSH. +Note that the SSH key pair must @emph{not} be passphrase-protected, to +allow non-interactive logins. + +@end table + +@noindent +A number of optional fields may be optionally specified: + +@table @code + +@item private-key +The SSH private key file to use when connecting to the machine. + +@item parallel-builds +The number of builds that may run in parallel on the machine (1 by +default.) + +@item speed +A ``relative speed factor''. The offload scheduler will tend to prefer +machines with a higher speed factor. + +@item features +A list of strings denoting specific features supported by the machine. +An example is @code{"kvm"} for machines that have the KVM Linux modules +and corresponding hardware support. Derivations can request features by +name, and they will be scheduled on matching build machines. + +@end table + +The @code{guix} command must be in the search path on the build +machines, since offloading works by invoking the @code{guix archive} and +@code{guix build} commands. + +There's one last thing to do once @file{machines.scm} is in place. As +explained above, when offloading, files are transferred back and forth +between the machine stores. For this to work, you need to generate a +key pair to allow the daemon to export signed archives of files from the +store (@pxref{Invoking guix archive}): + +@example +# guix archive --generate-key +@end example + +@noindent +Thus, when receiving files, a machine's build daemon can make sure they +are genuine, have not been tampered with, and that they are signed by an +authorized key. + + @node Invoking guix-daemon @section Invoking @command{guix-daemon} 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 +;;; +;;; 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 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 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 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 + ;; . + "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 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/ui.scm b/guix/ui.scm index bb811c557d..d6058f806b 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -559,7 +559,7 @@ (define (commands) (define (show-guix-help) (define (internal? command) - (member command '("substitute-binary" "authenticate"))) + (member command '("substitute-binary" "authenticate" "offload"))) (format #t (_ "Usage: guix COMMAND ARGS... Run COMMAND with ARGS.\n")) diff --git a/m4/guix.m4 b/m4/guix.m4 index a98378db79..19e041a72c 100644 --- a/m4/guix.m4 +++ b/m4/guix.m4 @@ -1,5 +1,5 @@ dnl GNU Guix --- Functional package management for GNU -dnl Copyright © 2012, 2013 Ludovic Courtès +dnl Copyright © 2012, 2013, 2014 Ludovic Courtès dnl dnl This file is part of GNU Guix. dnl @@ -134,3 +134,20 @@ AC_DEFUN([GUIX_CHECK_SRFI_37], [ ac_cv_guix_srfi_37_broken=yes fi]) ]) + +dnl GUIX_CHECK_UNBUFFERED_CBIP +dnl +dnl Check whether 'setbvuf' works on custom binary input ports (CBIPs), as is +dnl the case starting with Guile 2.0.10. +AC_DEFUN([GUIX_CHECK_UNBUFFERED_CBIP], [ + AC_CACHE_CHECK([whether Guile's custom binary input ports support 'setvbuf'], + [ac_cv_guix_cbips_support_setvbuf], + [if "$GUILE" -c "(use-modules (rnrs io ports)) \ + (let ((p (make-custom-binary-input-port \"cbip\" pk #f #f #f))) \ + (setvbuf p _IONBF))" >&5 2>&1 + then + ac_cv_guix_cbips_support_setvbuf=yes + else + ac_cv_guix_cbips_support_setvbuf=no + fi]) +]) diff --git a/nix/nix-daemon/guix-daemon.cc b/nix/nix-daemon/guix-daemon.cc index cf87e39354..d35b1cd076 100644 --- a/nix/nix-daemon/guix-daemon.cc +++ b/nix/nix-daemon/guix-daemon.cc @@ -1,5 +1,5 @@ /* GNU Guix --- Functional package management for GNU - Copyright (C) 2012, 2013 Ludovic Courtès + Copyright (C) 2012, 2013, 2014 Ludovic Courtès This file is part of GNU Guix. @@ -67,6 +67,7 @@ builds derivations on behalf of its clients."; #define GUIX_OPT_CHROOT_DIR 10 #define GUIX_OPT_LISTEN 11 #define GUIX_OPT_NO_SUBSTITUTES 12 +#define GUIX_OPT_NO_BUILD_HOOK 13 static const struct argp_option options[] = { @@ -94,6 +95,8 @@ static const struct argp_option options[] = "Perform builds as a user of GROUP" }, { "no-substitutes", GUIX_OPT_NO_SUBSTITUTES, 0, 0, "Do not use substitutes" }, + { "no-build-hook", GUIX_OPT_NO_BUILD_HOOK, 0, 0, + "Do not use the 'build hook'" }, { "cache-failures", GUIX_OPT_CACHE_FAILURES, 0, 0, "Cache build failures" }, { "lose-logs", GUIX_OPT_LOSE_LOGS, 0, 0, @@ -159,6 +162,9 @@ parse_opt (int key, char *arg, struct argp_state *state) case GUIX_OPT_NO_SUBSTITUTES: settings.useSubstitutes = false; break; + case GUIX_OPT_NO_BUILD_HOOK: + settings.useBuildHook = false; + break; case GUIX_OPT_DEBUG: verbosity = lvlDebug; break; @@ -226,6 +232,21 @@ main (int argc, char *argv[]) settings.substituters.clear (); settings.useSubstitutes = true; +#ifdef HAVE_DAEMON_OFFLOAD_HOOK + /* Use our build hook for distributed builds by default. */ + settings.useBuildHook = true; + if (getenv ("NIX_BUILD_HOOK") == NULL) + { + std::string build_hook; + + build_hook = settings.nixLibexecDir + "/guix/offload"; + setenv ("NIX_BUILD_HOOK", build_hook.c_str (), 1); + } +#else + /* We are not installing any build hook, so disable it. */ + settings.useBuildHook = false; +#endif + argp_parse (&argp, argc, argv, 0, 0, 0); if (settings.useSubstitutes) diff --git a/nix/scripts/offload.in b/nix/scripts/offload.in new file mode 100644 index 0000000000..50faed31c0 --- /dev/null +++ b/nix/scripts/offload.in @@ -0,0 +1,11 @@ +#!@SHELL@ +# A shorthand for "guix offload", for use by the daemon. + +if test "x$GUIX_UNINSTALLED" = "x" +then + prefix="@prefix@" + exec_prefix="@exec_prefix@" + exec "@bindir@/guix" offload "$@" +else + exec guix offload "$@" +fi diff --git a/pre-inst-env.in b/pre-inst-env.in index 3f1fa59bb8..e90e1b0ac4 100644 --- a/pre-inst-env.in +++ b/pre-inst-env.in @@ -1,7 +1,7 @@ #!/bin/sh # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013 Ludovic Courtès +# Copyright © 2012, 2013, 2014 Ludovic Courtès # # This file is part of GNU Guix. # @@ -44,7 +44,8 @@ export PATH 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 NIX_SUBSTITUTERS +NIX_BUILD_HOOK="$abs_top_builddir/nix/scripts/offload" +export NIX_ROOT_FINDER NIX_SETUID_HELPER NIX_SUBSTITUTERS NIX_BUILD_HOOK # The 'guix-register' program. GUIX_REGISTER="$abs_top_builddir/guix-register" -- cgit v1.2.3 From 9e55f04a4bb5b9d4f468d50c1ce8e19e8b0d0bd8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 24 Jan 2014 22:10:07 +0100 Subject: profiles: Remove misleading message. Fixes . Reported by Andreas Enge . * guix/profiles.scm (profile-derivation)[builder]: Remove "building profile '~a' with ~a packages" message. --- guix/profiles.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2013, 2014 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; ;;; This file is part of GNU Guix. @@ -238,8 +238,6 @@ (define builder (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") -- cgit v1.2.3 From 1909431c5b6413c496eb93d3d74be3e3e936951b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 25 Jan 2014 17:04:35 +0100 Subject: derivations: Add #:local-build? parameter for derivations. * guix/derivations.scm (derivation): Add #:local-build? parameter and honor it. (build-expression->derivation): Likewise. * doc/guix.texi (Derivations): Update documentation of these procedures. --- doc/guix.texi | 16 +++++++++++++--- guix/derivations.scm | 44 ++++++++++++++++++++++++++++---------------- 2 files changed, 41 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 325467c82d..91fa07f1a8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1452,7 +1452,11 @@ derivations as Scheme objects, along with procedures to create and otherwise manipulate derivations. The lowest-level primitive to create a derivation is the @code{derivation} procedure: -@deffn {Scheme Procedure} derivation @var{store} @var{name} @var{builder} @var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] [#:hash-mode #f] [#:inputs '()] [#:env-vars '()] [#:system (%current-system)] [#:references-graphs #f] +@deffn {Scheme Procedure} derivation @var{store} @var{name} @var{builder} @ + @var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @ + [#:hash-mode #f] [#:inputs '()] [#:env-vars '()] @ + [#:system (%current-system)] [#:references-graphs #f] @ + [#:local-build? #f] Build a derivation with the given arguments, and return the resulting @code{} object. @@ -1464,6 +1468,11 @@ When @var{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. + +When @var{local-build?} is true, declare that the derivation is not a +good candidate for offloading and should rather be built locally +(@pxref{Daemon Offload Setup}). This is the case for small derivations +where the costs of data transfers would outweigh the benefits. @end deffn @noindent @@ -1494,7 +1503,7 @@ the caller to directly pass a Guile expression as the build script: [#:system (%current-system)] [#:inputs '()] @ [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @ [#:env-vars '()] [#:modules '()] @ - [#:references-graphs #f] [#:guile-for-build #f] + [#:references-graphs #f] [#:local-build? #f] [#:guile-for-build #f] Return a derivation that executes Scheme expression @var{exp} as a builder for derivation @var{name}. @var{inputs} must be a list of @code{(name drv-path sub-drv)} tuples; when @var{sub-drv} is omitted, @@ -1516,7 +1525,8 @@ terminates by passing the result of @var{exp} to @code{exit}; thus, when @var{guile-for-build} is omitted or is @code{#f}, the value of the @code{%guile-for-build} fluid is used instead. -See the @code{derivation} procedure for the meaning of @var{references-graphs}. +See the @code{derivation} procedure for the meaning of @var{references-graphs} +and @var{local-build?}. @end deffn @noindent 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 +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -532,7 +532,8 @@ (define* (derivation store name builder args (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 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 @@ (define* (derivation store name builder args 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 @@ (define (user+system-env-vars) ;; 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 @@ (define* (build-expression->derivation store name exp (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 @@ (define* (build-expression->derivation store name exp 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 @@ (define %build-inputs #:hash hash #:hash-algo hash-algo #:outputs outputs - #:references-graphs references-graphs))) + #:references-graphs references-graphs + #:local-build? local-build?))) -- cgit v1.2.3