From 8856f409d13cd7376be4319b9f75df0692c009d6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Nov 2018 22:14:11 +0100 Subject: derivations: Add properties. * guix/derivations.scm (derivation): Add #:properties parameter. [user+system-env-vars]: Honor it. (derivation-properties): New procedure. (build-expression->derivation): Add #:properties and pass it to 'derivation'. * guix/gexp.scm (gexp->derivation): Likewise. * tests/derivations.scm ("derivation-properties"): New test. * tests/gexp.scm ("gexp->derivation properties"): New test. * doc/guix.texi (Derivations, G-Expressions): Adjust accordingly. --- tests/derivations.scm | 10 ++++++++++ tests/gexp.scm | 10 +++++++++- 2 files changed, 19 insertions(+), 1 deletion(-) (limited to 'tests') diff --git a/tests/derivations.scm b/tests/derivations.scm index 159a6971b3..5f294c1827 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -1132,6 +1132,16 @@ ((p2 . _) (stringderivation %store "bar" + '(mkdir %output))) + (drv2 (build-expression->derivation %store "foo" + '(mkdir %output) + #:properties '((type . test))))) + (list (derivation-properties drv1) + (derivation-properties drv2)))) + (test-equal "map-derivation" "hello" (let* ((joke (package-derivation %store guile-1.8)) diff --git a/tests/gexp.scm b/tests/gexp.scm index ab60bdab68..7ae9201c81 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -476,7 +476,15 @@ (return (and (string=? (readlink (string-append out "/foo")) guile) (string=? (readlink out2) file) (equal? refs (list (dirname (dirname guile)))) - (equal? refs2 (list file)))))) + (equal? refs2 (list file)) + (null? (derivation-properties drv)))))) + +(test-assertm "gexp->derivation properties" + (mlet %store-monad ((drv (gexp->derivation "foo" + #~(mkdir #$output) + #:properties '((type . test))))) + (return (equal? '((type . test)) + (derivation-properties drv))))) (test-assertm "gexp->derivation vs. grafts" (mlet* %store-monad ((graft? (set-grafting #f)) -- cgit v1.2.3 From 64fd1c01bc6f1be6ffcafc08789d5dafb9850c2e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Nov 2018 22:27:39 +0100 Subject: grafts: Record metadata as derivation properties. * guix/grafts.scm (graft-derivation/shallow): Pass #:properties to 'build-expression->derivation'. * tests/grafts.scm ("graft-derivation, grafted item is a direct dependency"): Check the value returned by 'derivation-properties'. --- guix/grafts.scm | 7 ++++++- tests/grafts.scm | 13 ++++++++----- 2 files changed, 14 insertions(+), 6 deletions(-) (limited to 'tests') diff --git a/guix/grafts.scm b/guix/grafts.scm index 01e245d8eb..63f384555b 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -123,6 +123,10 @@ are not recursively applied to dependencies of DRV." (define add-label (cut cons "x" <>)) + (define properties + `((type . graft) + (graft (count . ,(length grafts))))) + (match grafts ((($ sources source-outputs targets target-outputs) ...) (let ((sources (zip sources source-outputs)) @@ -140,7 +144,8 @@ are not recursively applied to dependencies of DRV." ,@(append (map add-label sources) (map add-label targets))) #:outputs outputs - #:local-build? #t))))) + #:local-build? #t + #:properties properties))))) (define (item->deriver store item) "Return two values: the derivation that led to ITEM (a store item), and the name of the output of that derivation ITEM corresponds to (for example diff --git a/tests/grafts.scm b/tests/grafts.scm index abb074d628..f85f3c6913 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,7 +51,8 @@ (test-begin "grafts") -(test-assert "graft-derivation, grafted item is a direct dependency" +(test-equal "graft-derivation, grafted item is a direct dependency" + '((type . graft) (graft (count . 2))) (let* ((build `(begin (mkdir %output) (chdir %output) @@ -76,14 +77,16 @@ (origin %mkdir) (replacement two)))))) (and (build-derivations %store (list grafted)) - (let ((two (derivation->output-path two)) - (grafted (derivation->output-path grafted))) + (let ((properties (derivation-properties grafted)) + (two (derivation->output-path two)) + (grafted (derivation->output-path grafted))) (and (string=? (format #f "foo/~a/bar" two) (call-with-input-file (string-append grafted "/text") get-string-all)) (string=? (readlink (string-append grafted "/sh")) one) (string=? (readlink (string-append grafted "/self")) - grafted)))))) + grafted) + properties))))) (test-assert "graft-derivation, grafted item uses a different name" (let* ((build `(begin -- cgit v1.2.3 From 94c0e61fe759924625c9e27d3da8c7c0c767ea2b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Nov 2018 11:48:33 +0100 Subject: inferior: Add 'inferior-eval-with-store'. * guix/inferior.scm (inferior-eval-with-store): New procedure, with code formerly in 'inferior-package-derivation'. (inferior-package-derivation): Rewrite in terms of 'inferior-eval-with-store'. * tests/inferior.scm ("inferior-eval-with-store"): New test. --- guix/inferior.scm | 70 +++++++++++++++++++++++++++++++++--------------------- tests/inferior.scm | 9 +++++++ 2 files changed, 52 insertions(+), 27 deletions(-) (limited to 'tests') diff --git a/guix/inferior.scm b/guix/inferior.scm index 1dbb9e1699..ccc1c27cb2 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -56,6 +56,7 @@ open-inferior close-inferior inferior-eval + inferior-eval-with-store inferior-object? inferior-packages @@ -402,55 +403,70 @@ input/output ports.)" (unless (port-closed? client) (loop)))))) -(define* (inferior-package-derivation store package - #:optional - (system (%current-system)) - #:key target) - "Return the derivation for PACKAGE, an inferior package, built for SYSTEM -and cross-built for TARGET if TARGET is true. The inferior corresponding to -PACKAGE must be live." - ;; Create a named socket in /tmp and let the inferior of PACKAGE connect to - ;; it and use it as its store. This ensures the inferior uses the same - ;; store, with the same options, the same per-session GC roots, etc. +(define (inferior-eval-with-store inferior store code) + "Evaluate CODE in INFERIOR, passing it STORE as its argument. CODE must +thus be the code of a one-argument procedure that accepts a store." + ;; Create a named socket in /tmp and let INFERIOR connect to it and use it + ;; as its store. This ensures the inferior uses the same store, with the + ;; same options, the same per-session GC roots, etc. (call-with-temporary-directory (lambda (directory) (chmod directory #o700) (let* ((name (string-append directory "/inferior")) (socket (socket AF_UNIX SOCK_STREAM 0)) - (inferior (inferior-package-inferior package)) (major (nix-server-major-version store)) (minor (nix-server-minor-version store)) (proto (logior major minor))) (bind socket AF_UNIX name) (listen socket 1024) (send-inferior-request - `(let ((socket (socket AF_UNIX SOCK_STREAM 0))) + `(let ((proc ,code) + (socket (socket AF_UNIX SOCK_STREAM 0))) (connect socket AF_UNIX ,name) ;; 'port->connection' appeared in June 2018 and we can hardly ;; emulate it on older versions. Thus fall back to ;; 'open-connection', at the risk of talking to the wrong daemon or ;; having our build result reclaimed (XXX). - (let* ((store (if (defined? 'port->connection) - (port->connection socket #:version ,proto) - (open-connection))) - (package (hashv-ref %package-table - ,(inferior-package-id package))) - (drv ,(if target - `(package-cross-derivation store package - ,target - ,system) - `(package-derivation store package - ,system)))) - (close-connection store) - (close-port socket) - (derivation-file-name drv))) + (let ((store (if (defined? 'port->connection) + (port->connection socket #:version ,proto) + (open-connection)))) + (dynamic-wind + (const #t) + (lambda () + (proc store)) + (lambda () + (close-connection store) + (close-port socket))))) inferior) (match (accept socket) ((client . address) (proxy client (nix-server-socket store)))) (close-port socket) - (read-derivation-from-file (read-inferior-response inferior)))))) + (read-inferior-response inferior))))) + +(define* (inferior-package-derivation store package + #:optional + (system (%current-system)) + #:key target) + "Return the derivation for PACKAGE, an inferior package, built for SYSTEM +and cross-built for TARGET if TARGET is true. The inferior corresponding to +PACKAGE must be live." + (define proc + `(lambda (store) + (let* ((package (hashv-ref %package-table + ,(inferior-package-id package))) + (drv ,(if target + `(package-cross-derivation store package + ,target + ,system) + `(package-derivation store package + ,system)))) + (derivation-file-name drv)))) + + (and=> (inferior-eval-with-store (inferior-package-inferior package) store + proc) + read-derivation-from-file)) (define inferior-package->derivation (store-lift inferior-package-derivation)) diff --git a/tests/inferior.scm b/tests/inferior.scm index d1d5c00a77..d5a894ca8f 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -157,6 +157,15 @@ (close-inferior inferior) result)) +(test-equal "inferior-eval-with-store" + (add-text-to-store %store "foo" "Hello, world!") + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (inferior-eval-with-store inferior %store + '(lambda (store) + (add-text-to-store store "foo" + "Hello, world!"))))) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") -- cgit v1.2.3