From 3483f004a98f103acff96effe1309cc620372e79 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 24 Jan 2017 00:35:16 +0100 Subject: syscalls: Export 'read-utmpx'. * guix/build/syscalls.scm (read-utmpx-from-port): New procedure. * tests/syscalls.scm ("read-utmpx, EOF") ("read-utmpx"): New tests. --- guix/build/syscalls.scm | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 475fc96490..b68c48a05a 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -21,6 +21,7 @@ (define-module (guix build syscalls) #:use-module (system foreign) #:use-module (rnrs bytevectors) + #:autoload (ice-9 binary-ports) (get-bytevector-n) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) @@ -142,7 +143,8 @@ utmpx-time utmpx-address login-type - utmpx-entries)) + utmpx-entries + (read-utmpx-from-port . read-utmpx))) ;;; Commentary: ;;; @@ -1598,4 +1600,13 @@ always a positive integer." ((? utmpx? entry) (loop (cons entry entries)))))) +(define (read-utmpx-from-port port) + "Read a utmpx entry from PORT. Return either the EOF object or a utmpx +entry." + (match (get-bytevector-n port sizeof-utmpx) + ((? eof-object? eof) + eof) + ((? bytevector? bv) + (read-utmpx bv)))) + ;;; syscalls.scm ends here -- cgit v1.2.3 From fd7d1235f1d2e053bbc20d555bd9eed889845ca2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 24 Jan 2017 17:48:24 +0100 Subject: grafts: Shallow grafting can be performed on a subset of the outputs. * guix/grafts.scm (graft-derivation/shallow): Add #:outputs parameter. [outputs]: Rename to... [output-pairs]: ... this. Adjust 'build-expression->derivation' call accordingly. --- guix/grafts.scm | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index e14a40f8d1..e44fc0544f 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -78,11 +78,12 @@ (define* (graft-derivation/shallow store drv grafts #:key (name (derivation-name drv)) + (outputs (derivation-output-names drv)) (guile (%guile-for-build)) (system (%current-system))) - "Return a derivation called NAME, based on DRV but with all the GRAFTS -applied. This procedure performs \"shallow\" grafting in that GRAFTS are not -recursively applied to dependencies of DRV." + "Return a derivation called NAME, which applies GRAFTS to the specified +OUTPUTS of DRV. This procedure performs \"shallow\" grafting in that GRAFTS +are not recursively applied to dependencies of DRV." ;; XXX: Someday rewrite using gexps. (define mapping ;; List of store item pairs. @@ -96,14 +97,12 @@ recursively applied to dependencies of DRV." target)))) grafts)) - (define outputs - (map (match-lambda - ((name . output) - (cons name (derivation-output-path output)))) - (derivation-outputs drv))) - - (define output-names - (derivation-output-names drv)) + (define output-pairs + (map (lambda (output) + (cons output + (derivation-output-path + (assoc-ref (derivation-outputs drv) output)))) + outputs)) (define build `(begin @@ -111,7 +110,7 @@ recursively applied to dependencies of DRV." (guix build utils) (ice-9 match)) - (let* ((old-outputs ',outputs) + (let* ((old-outputs ',output-pairs) (mapping (append ',mapping (map (match-lambda ((name . file) @@ -143,10 +142,10 @@ recursively applied to dependencies of DRV." (guix build utils)) #:inputs `(,@(map (lambda (out) `("x" ,drv ,out)) - output-names) + outputs) ,@(append (map add-label sources) (map add-label targets))) - #:outputs output-names + #:outputs outputs #:local-build? #t))))) (define (item->deriver store item) "Return two values: the derivation that led to ITEM (a store item), and the -- cgit v1.2.3 From 482fda2729c3e76999892cb8f9a0391a7bd37119 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Jan 2017 10:20:02 +0100 Subject: grafts: Do not pull derivation outputs not depended on. Fixes . Previously, the grafting derivation of, say, brdf-explorer would pull in qt:doc even though brdf-explorer depends only on qt:out, not qt:doc. * guix/grafts.scm (with-cache): Use 'vhash-assoc' and 'vhash-cons' instead of 'vhash-assq' and 'vhash-consq'. (cumulative-grafts): Pass #:outputs to 'graft-derivation/shallow'. Use OUTPUTS instead of (derivation-output-names drv). (graft-derivation): Add #:outputs parameter; pass it to 'cumulative-grafts'. * tests/grafts.scm (make-derivation-input): New variable. ("graft-derivation, replaced derivation has multiple outputs"): Make sure P2:zzz is not part of the outputs of P3D. ("graft-derivation with #:outputs") ("graft-derivation, unused outputs not depended on"): New tests. --- guix/grafts.scm | 25 ++++++------ tests/grafts.scm | 118 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 128 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index e44fc0544f..11885db226 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -216,14 +216,14 @@ available." (define-syntax-rule (with-cache key exp ...) "Cache the value of monadic expression EXP under KEY." (mlet %state-monad ((cache (current-state))) - (match (vhash-assq key cache) + (match (vhash-assoc key cache) ((_ . result) ;cache hit (return result)) (#f ;cache miss (mlet %state-monad ((result (begin exp ...)) (cache (current-state))) (mbegin %state-monad - (set-current-state (vhash-consq key result cache)) + (set-current-state (vhash-cons key result cache)) (return result))))))) (define* (cumulative-grafts store drv grafts @@ -264,7 +264,7 @@ derivations to the corresponding set of grafts." #:system system)) (state-return grafts)))) - (with-cache drv + (with-cache (cons (derivation-file-name drv) outputs) (match (non-self-references references drv outputs) (() ;no dependencies (return grafts)) @@ -281,29 +281,27 @@ derivations to the corresponding set of grafts." ;; applicable to DRV, to avoid creating several identical ;; grafted variants of DRV. (let* ((new (graft-derivation/shallow store drv applicable + #:outputs outputs #:guile guile #:system system)) - - ;; Replace references to any of the outputs of DRV, - ;; even if that's more than needed. This is so that - ;; the result refers only to the outputs of NEW and - ;; not to those of DRV. (grafts (append (map (lambda (output) (graft (origin drv) (origin-output output) (replacement new) (replacement-output output))) - (derivation-output-names drv)) + outputs) grafts))) (return grafts)))))))))) (define* (graft-derivation store drv grafts - #:key (guile (%guile-for-build)) + #:key + (guile (%guile-for-build)) + (outputs (derivation-output-names drv)) (system (%current-system))) - "Applied GRAFTS to DRV and all its dependencies, recursively. That is, if -GRAFTS apply only indirectly to DRV, graft the dependencies of DRV, and graft -DRV itself to refer to those grafted dependencies." + "Apply GRAFTS to the OUTPUTS of DRV and all their dependencies, recursively. +That is, if GRAFTS apply only indirectly to DRV, graft the dependencies of +DRV, and graft DRV itself to refer to those grafted dependencies." ;; First, pre-compute the dependency tree of the outputs of DRV. Do this ;; upfront to have as much parallelism as possible when querying substitute @@ -313,6 +311,7 @@ DRV itself to refer to those grafted dependencies." (match (run-with-state (cumulative-grafts store drv grafts references + #:outputs outputs #:guile guile #:system system) vlist-null) ;the initial cache ((first . rest) diff --git a/tests/grafts.scm b/tests/grafts.scm index 6454a03b1f..08f05c0f75 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -43,6 +43,9 @@ (define %mkdir (bootstrap-binary "mkdir")) +(define make-derivation-input + (@@ (guix derivations) make-derivation-input)) + (test-begin "grafts") @@ -241,7 +244,18 @@ (replacement p1r) (replacement-output "ONE"))) (p3d (graft-derivation %store p3 (list p1g)))) - (and (build-derivations %store (list p3d)) + + (and (not (find (lambda (input) + ;; INPUT should not be P2:zzz since the result of P3 + ;; does not depend on it. See + ;; . + (and (string=? (derivation-input-path input) + (derivation-file-name p2)) + (member "zzz" + (derivation-input-sub-derivations input)))) + (derivation-inputs p3d))) + + (build-derivations %store (list p3d)) (let ((out (derivation->output-path (pk 'p2d p3d)))) (and (not (string=? (readlink out) (derivation->output-path p2 "aaa"))) @@ -249,6 +263,106 @@ (readlink (string-append out "/two"))) (file-exists? (string-append out "/one/replacement"))))))) +(test-assert "graft-derivation with #:outputs" + ;; Call 'graft-derivation' with a narrowed set of outputs passed as + ;; #:outputs. + (let* ((p1 (build-expression->derivation + %store "p1" + `(let ((one (assoc-ref %outputs "one")) + (two (assoc-ref %outputs "two"))) + (mkdir one) + (mkdir two)) + #:outputs '("one" "two"))) + (p1r (build-expression->derivation + %store "P1" + `(let ((other (assoc-ref %outputs "ONE"))) + (mkdir other) + (call-with-output-file (string-append other "/replacement") + (const #t))) + #:outputs '("ONE"))) + (p2 (build-expression->derivation + %store "p2" + `(let ((aaa (assoc-ref %outputs "aaa")) + (zzz (assoc-ref %outputs "zzz"))) + (mkdir zzz) (chdir zzz) + (mkdir aaa) (chdir aaa) + (symlink (assoc-ref %build-inputs "p1:two") "two")) + #:outputs '("aaa" "zzz") + #:inputs `(("p1:one" ,p1 "one") + ("p1:two" ,p1 "two")))) + (p1g (graft + (origin p1) + (origin-output "one") + (replacement p1r) + (replacement-output "ONE"))) + (p2g (graft-derivation %store p2 (list p1g) + #:outputs '("aaa")))) + ;; P2:aaa depends on P1:two, but not on P1:one, so nothing to graft. + (eq? p2g p2))) + +(test-equal "graft-derivation, unused outputs not depended on" + '("aaa") + + ;; Make sure that the result of 'graft-derivation' does not pull outputs + ;; that are irrelevant to the grafting process. See + ;; . + (let* ((p1 (build-expression->derivation + %store "p1" + `(let ((one (assoc-ref %outputs "one")) + (two (assoc-ref %outputs "two"))) + (mkdir one) + (mkdir two)) + #:outputs '("one" "two"))) + (p1r (build-expression->derivation + %store "P1" + `(let ((other (assoc-ref %outputs "ONE"))) + (mkdir other) + (call-with-output-file (string-append other "/replacement") + (const #t))) + #:outputs '("ONE"))) + (p2 (build-expression->derivation + %store "p2" + `(let ((aaa (assoc-ref %outputs "aaa")) + (zzz (assoc-ref %outputs "zzz"))) + (mkdir zzz) (chdir zzz) + (symlink (assoc-ref %build-inputs "p1:two") "two") + (mkdir aaa) (chdir aaa) + (symlink (assoc-ref %build-inputs "p1:one") "one")) + #:outputs '("aaa" "zzz") + #:inputs `(("p1:one" ,p1 "one") + ("p1:two" ,p1 "two")))) + (p1g (graft + (origin p1) + (origin-output "one") + (replacement p1r) + (replacement-output "ONE"))) + (p2g (graft-derivation %store p2 (list p1g) + #:outputs '("aaa")))) + + ;; Here P2G should only depend on P1:one and P1R:one; it must not depend + ;; on P1:two or P1R:two since these are unused in the grafting process. + (and (not (eq? p2g p2)) + (let* ((inputs (derivation-inputs p2g)) + (match-input (lambda (drv) + (lambda (input) + (string=? (derivation-input-path input) + (derivation-file-name drv))))) + (p1-inputs (filter (match-input p1) inputs)) + (p1r-inputs (filter (match-input p1r) inputs)) + (p2-inputs (filter (match-input p2) inputs))) + (and (equal? p1-inputs + (list (make-derivation-input (derivation-file-name p1) + '("one")))) + (equal? p1r-inputs + (list + (make-derivation-input (derivation-file-name p1r) + '("ONE")))) + (equal? p2-inputs + (list + (make-derivation-input (derivation-file-name p2) + '("aaa")))) + (derivation-output-names p2g)))))) + (test-assert "graft-derivation, renaming" ; (let* ((build `(begin (use-modules (guix build utils)) -- cgit v1.2.3 From 0ca575f3bbb6de07469d5bf285ff1a8878a74e1e Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 25 Jan 2017 07:24:20 +0000 Subject: container: Pass through TERM when calling exec. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/container/exec.scm (guix-container-exec): Capture the value of the TERM environment variable, and pass it through to the container. This means some applications now work where they did not before (e.g. htop), and others have more functionality, providing that the terminal was capable of enabling that functionality in the first place. Co-authored-by: Ludovic Courtès --- guix/scripts/container/exec.scm | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm index 10e70568cc..d6d267daff 100644 --- a/guix/scripts/container/exec.scm +++ b/guix/scripts/container/exec.scm @@ -74,7 +74,14 @@ and the other containing arguments for the command to be executed." (let* ((opts (parse-command-line args %options '(()) #:argument-handler handle-argument)) - (pid (assoc-ref opts 'pid))) + (pid (assoc-ref opts 'pid)) + (environment (filter-map (lambda (name) + (let ((value (getenv name))) + (and value (cons name value)))) + ;; Pass through the TERM environment + ;; variable to inform processes about + ;; the capabilities of the terminal. + '("TERM")))) (unless pid (leave (_ "no pid specified~%"))) @@ -89,6 +96,10 @@ and the other containing arguments for the command to be executed." (lambda () (match command ((program . program-args) + (for-each (match-lambda + ((name . value) + (setenv name value))) + environment) (apply execlp program program program-args))))))) (unless (zero? result) (leave (_ "exec failed with status ~d~%") result))))))) -- cgit v1.2.3