From 82f5186650dc5546eaa4cdc918c444632fa8086f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 27 Feb 2016 23:00:22 +0100 Subject: grafts: Make sure files are not created world-writable. * guix/build/graft.scm (rewrite-directory): Add 'umask' call. --- guix/build/graft.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/graft.scm b/guix/build/graft.scm index 0a9cd3260c..b216e6c0d7 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -118,6 +118,11 @@ file name pairs." (else (error "unsupported file type" stat))))) + ;; XXX: Work around occasional "suspicious ownership or permission" daemon + ;; errors that arise when we create the top-level /gnu/store/… directory as + ;; #o777. + (umask #o022) + (n-par-for-each (parallel-job-count) rewrite-leaf (find-files directory))) -- cgit v1.2.3 From cd05d388121d6a9d7ee83aefa29d3c3b255b7552 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 27 Feb 2016 23:10:48 +0100 Subject: grafts: Slight simplification. * guix/grafts.scm (graft-derivation)[output-names]: Use 'derivation-output-names'. --- guix/grafts.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index a1f7d8801a..339f273b76 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -87,9 +87,7 @@ applied." (map derivation-output-path outputs)))) (define output-names - (match (derivation-outputs drv) - (((names . outputs) ...) - names))) + (derivation-output-names drv)) (define build `(begin -- cgit v1.2.3 From f376dc3acb69a7345a7e945a37a78f63ac626edb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 27 Feb 2016 23:28:35 +0100 Subject: grafts: Consider all the outputs in the graft mapping. Before that, outputs of a derivation could be left referring to the ungrafted version of the derivation. * guix/grafts.scm (graft-derivation)[outputs]: Change to a list of name/file pairs. * guix/grafts.scm (graft-derivation)[build]: Add 'old-outputs' variable and use it when computing 'mapping'. Use 'mapping' directly. * tests/grafts.scm ("graft-derivation, multiple outputs"): New test. --- guix/grafts.scm | 23 +++++++++++++++-------- tests/grafts.scm | 20 ++++++++++++++++++++ 2 files changed, 35 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index 339f273b76..ea53959b37 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -82,9 +82,10 @@ applied." grafts)) (define outputs - (match (derivation-outputs drv) - (((names . outputs) ...) - (map derivation-output-path outputs)))) + (map (match-lambda + ((name . output) + (cons name (derivation-output-path output)))) + (derivation-outputs drv))) (define output-names (derivation-output-names drv)) @@ -95,14 +96,20 @@ applied." (guix build utils) (ice-9 match)) - (let ((mapping ',mapping)) + (let* ((old-outputs ',outputs) + (mapping (append ',mapping + (map (match-lambda + ((name . file) + (cons (assoc-ref old-outputs name) + file))) + %outputs)))) (for-each (lambda (input output) (format #t "grafting '~a' -> '~a'...~%" input output) (force-output) - (rewrite-directory input output - `((,input . ,output) - ,@mapping))) - ',outputs + (rewrite-directory input output mapping)) + (match old-outputs + (((names . files) ...) + files)) (match %outputs (((names . files) ...) files)))))) diff --git a/tests/grafts.scm b/tests/grafts.scm index 4a4122a3e9..9fe314d183 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -75,6 +75,26 @@ (string=? (readlink (string-append graft "/sh")) one) (string=? (readlink (string-append graft "/self")) graft)))))) +(test-assert "graft-derivation, multiple outputs" + (let* ((build `(begin + (symlink (assoc-ref %build-inputs "a") + (assoc-ref %outputs "one")) + (symlink (assoc-ref %outputs "one") + (assoc-ref %outputs "two")))) + (orig (build-expression->derivation %store "grafted" build + #:inputs `(("a" ,%bash)) + #:outputs '("one" "two"))) + (repl (add-text-to-store %store "bash" "fake bash")) + (grafted (graft-derivation %store orig + (list (graft + (origin %bash) + (replacement repl)))))) + (and (build-derivations %store (list grafted)) + (let ((one (derivation->output-path grafted "one")) + (two (derivation->output-path grafted "two"))) + (and (string=? (readlink one) repl) + (string=? (readlink two) one)))))) + (test-end) -- cgit v1.2.3 From c22a1324e64d6906be5e9a8e64b8716ad763434a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 27 Feb 2016 23:06:50 +0100 Subject: grafts: Graft recursively. Fixes . * guix/grafts.scm (graft-derivation): Rename to... (graft-derivation/shallow): ... this. (graft-origin-file-name, item->deriver, non-self-references) (cumulative-grafts, graft-derivation): New procedures * tests/grafts.scm ("graft-derivation, grafted item is a direct dependency"): Clarify title. Use 'grafted' instead of 'graft' to refer to the grafted derivation. ("graft-derivation, grafted item is an indirect dependency") ("graft-derivation, no dependencies on grafted output"): New tests. * guix/packages.scm (input-graft): Change to take a package instead of an input. (input-cross-graft): Likewise. (fold-bag-dependencies): New procedure. (bag-grafts): Rewrite in terms of 'fold-bag-dependencies'. * tests/packages.scm ("package-derivation, indirect grafts"): Comment out. * doc/guix.texi (Security Updates): Mention run-time dependencies and recursive grafting. --- doc/guix.texi | 9 ++-- guix/grafts.scm | 104 +++++++++++++++++++++++++++++++++++++--- guix/packages.scm | 126 ++++++++++++++++++++++++++++++++----------------- guix/scripts/graph.scm | 5 +- tests/grafts.scm | 93 ++++++++++++++++++++++++++++++------ tests/packages.scm | 38 ++++++++------- 6 files changed, 290 insertions(+), 85 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 4c9a91b399..5e62703380 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10244,11 +10244,14 @@ Packages}). Then, the original package definition is augmented with a (replacement bash-fixed))) @end example -From there on, any package depending directly or indirectly on Bash that -is installed will automatically be ``rewritten'' to refer to +From there on, any package depending directly or indirectly on Bash---as +reported by @command{guix gc --requisites} (@pxref{Invoking guix +gc})---that is installed is automatically ``rewritten'' to refer to @var{bash-fixed} instead of @var{bash}. This grafting process takes time proportional to the size of the package, but expect less than a -minute for an ``average'' package on a recent machine. +minute for an ``average'' package on a recent machine. Grafting is +recursive: when an indirect dependency requires grafting, then grafting +``propagates'' up to the package that the user is installing. Currently, the graft and the package it replaces (@var{bash-fixed} and @var{bash} in the example above) must have the exact same @code{name} diff --git a/guix/grafts.scm b/guix/grafts.scm index ea53959b37..9bcc5e2ef8 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -17,11 +17,14 @@ ;;; along with GNU Guix. If not, see . (define-module (guix grafts) + #:use-module (guix store) + #:use-module (guix monads) #:use-module (guix records) #:use-module (guix derivations) #:use-module ((guix utils) #:select (%current-system)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (graft? @@ -32,6 +35,7 @@ graft-replacement-output graft-derivation + graft-derivation/shallow %graft? set-grafting)) @@ -61,13 +65,22 @@ (set-record-type-printer! write-graft) -(define* (graft-derivation store drv grafts - #:key - (name (derivation-name drv)) - (guile (%guile-for-build)) - (system (%current-system))) +(define (graft-origin-file-name graft) + "Return the output file name of the origin of GRAFT." + (match graft + (($ (? derivation? origin) output) + (derivation->output-path origin output)) + (($ (? string? item)) + item))) + +(define* (graft-derivation/shallow store drv grafts + #:key + (name (derivation-name drv)) + (guile (%guile-for-build)) + (system (%current-system))) "Return a derivation called NAME, based on DRV but with all the GRAFTS -applied." +applied. 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. @@ -133,6 +146,85 @@ applied." (map add-label targets))) #:outputs output-names #:local-build? #t))))) +(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 +\"out\"). When ITEM has no deriver, for instance because it is a plain file, +#f and #f are returned." + (match (valid-derivers store item) + (() ;ITEM is a plain file + (values #f #f)) + ((drv-file _ ...) + (let ((drv (call-with-input-file drv-file read-derivation))) + (values drv + (any (match-lambda + ((name . path) + (and (string=? item path) name))) + (derivation->output-paths drv))))))) + +(define (non-self-references store drv outputs) + "Return the list of references of the OUTPUTS of DRV, excluding self +references." + (let ((refs (append-map (lambda (output) + (references store + (derivation->output-path drv output))) + outputs)) + (self (match (derivation->output-paths drv) + (((names . items) ...) + items)))) + (remove (cut member <> self) refs))) + +(define* (cumulative-grafts store drv grafts + #:key + (outputs (derivation-output-names drv)) + (guile (%guile-for-build)) + (system (%current-system))) + "Augment GRAFTS with additional grafts resulting from the application of +GRAFTS to the dependencies of DRV. Return the resulting list of grafts." + (define (dependency-grafts item) + (let-values (((drv output) (item->deriver store item))) + (if drv + (cumulative-grafts store drv grafts + #:outputs (list output) + #:guile guile + #:system system) + grafts))) + + ;; TODO: Memoize. + (match (non-self-references store drv outputs) + (() ;no dependencies + grafts) + (deps ;one or more dependencies + (let* ((grafts (delete-duplicates (append-map dependency-grafts deps) + eq?)) + (origins (map graft-origin-file-name grafts))) + (if (find (cut member <> deps) origins) + (let ((new (graft-derivation/shallow store drv grafts + #:guile guile + #:system system))) + (cons (graft (origin drv) (replacement new)) + grafts)) + grafts))))) + +(define* (graft-derivation store drv grafts + #:key (guile (%guile-for-build)) + (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." + + ;; First, we need to build the ungrafted DRV so we can query its run-time + ;; dependencies in 'cumulative-grafts'. + (build-derivations store (list drv)) + + (match (cumulative-grafts store drv grafts + #:guile guile #:system system) + ((first . rest) + ;; If FIRST is not a graft for DRV, it means that GRAFTS are not + ;; applicable to DRV and nothing needs to be done. + (if (equal? drv (graft-origin first)) + (graft-replacement first) + drv)))) ;; The following might feel more at home in (guix packages) but since (guix diff --git a/guix/packages.scm b/guix/packages.scm index f6afaeb510..3e50260069 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -30,6 +30,7 @@ #:use-module (guix build-system) #:use-module (guix search-paths) #:use-module (guix gexp) + #:use-module (guix sets) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) @@ -831,30 +832,25 @@ and return it." (package package)))))))))) (define (input-graft store system) - "Return a procedure that, given an input referring to a package with a -graft, returns a pair with the original derivation and the graft's derivation, -and returns #f for other inputs." + "Return a procedure that, given a package with a graft, returns a graft, and +#f otherwise." (match-lambda - ((label (? package? package) sub-drv ...) - (let ((replacement (package-replacement package))) - (and replacement - (let ((orig (package-derivation store package system - #:graft? #f)) - (new (package-derivation store replacement system))) - (graft - (origin orig) - (replacement new) - (origin-output (match sub-drv - (() "out") - ((output) output))) - (replacement-output origin-output)))))) - (x - #f))) + ((? package? package) + (let ((replacement (package-replacement package))) + (and replacement + (let ((orig (package-derivation store package system + #:graft? #f)) + (new (package-derivation store replacement system))) + (graft + (origin orig) + (replacement new)))))) + (x + #f))) (define (input-cross-graft store target system) "Same as 'input-graft', but for cross-compilation inputs." (match-lambda - ((label (? package? package) sub-drv ...) + ((? package? package) (let ((replacement (package-replacement package))) (and replacement (let ((orig (package-cross-derivation store package target system @@ -863,34 +859,75 @@ and returns #f for other inputs." target system))) (graft (origin orig) - (replacement new) - (origin-output (match sub-drv - (() "out") - ((output) output))) - (replacement-output origin-output)))))) + (replacement new)))))) (_ #f))) -(define* (bag-grafts store bag) - "Return the list of grafts applicable to BAG. Each graft is a -record." - (let ((target (bag-target bag)) - (system (bag-system bag))) - (define native-grafts - (filter-map (input-graft store system) - (append (bag-transitive-build-inputs bag) - (bag-transitive-target-inputs bag) - (if target - '() - (bag-transitive-host-inputs bag))))) - - (define target-grafts - (if target - (filter-map (input-cross-graft store target system) - (bag-transitive-host-inputs bag)) - '())) +(define* (fold-bag-dependencies proc seed bag + #:key (native? #t)) + "Fold PROC over the packages BAG depends on. Each package is visited only +once, in depth-first order. If NATIVE? is true, restrict to native +dependencies; otherwise, restrict to target dependencies." + (define nodes + (match (if native? + (append (bag-build-inputs bag) + (bag-target-inputs bag) + (if (bag-target bag) + '() + (bag-host-inputs bag))) + (bag-host-inputs bag)) + (((labels things _ ...) ...) + things))) + + (let loop ((nodes nodes) + (result seed) + (visited (setq))) + (match nodes + (() + result) + (((? package? head) . tail) + (if (set-contains? visited head) + (loop tail result visited) + (let ((inputs (bag-direct-inputs (package->bag head)))) + (loop (match inputs + (((labels things _ ...) ...) + (append things tail))) + (proc head result) + (set-insert head visited))))) + ((head . tail) + (loop tail result visited))))) - (append native-grafts target-grafts))) +(define* (bag-grafts store bag) + "Return the list of grafts potentially applicable to BAG. Potentially +applicable grafts are collected by looking at direct or indirect dependencies +of BAG that have a 'replacement'. Whether a graft is actually applicable +depends on whether the outputs of BAG depend on the items the grafts refer +to (see 'graft-derivation'.)" + (define system (bag-system bag)) + (define target (bag-target bag)) + + (define native-grafts + (let ((->graft (input-graft store system))) + (fold-bag-dependencies (lambda (package grafts) + (match (->graft package) + (#f grafts) + (graft (cons graft grafts)))) + '() + bag))) + + (define target-grafts + (if target + (let ((->graft (input-cross-graft store target system))) + (fold-bag-dependencies (lambda (package grafts) + (match (->graft package) + (#f grafts) + (graft (cons graft grafts)))) + '() + bag + #:native? #f)) + '())) + + (append native-grafts target-grafts)) (define* (package-grafts store package #:optional (system (%current-system)) @@ -985,6 +1022,9 @@ This is an internal procedure." (grafts (let ((guile (package-derivation store (default-guile) system #:graft? #f))) + ;; TODO: As an optimization, we can simply graft the tip + ;; of the derivation graph since 'graft-derivation' + ;; recurses anyway. (graft-derivation store drv grafts #:system system #:guile guile)))) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index dcc4701779..2d1c1ff59f 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -19,6 +19,7 @@ (define-module (guix scripts graph) #:use-module (guix ui) #:use-module (guix graph) + #:use-module (guix grafts) #:use-module (guix scripts) #:use-module (guix utils) #:use-module (guix packages) @@ -352,7 +353,9 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) opts))) (with-store store (run-with-store store - (mlet %store-monad ((nodes (mapm %store-monad + ;; XXX: Since grafting can trigger unsolicited builds, disable it. + (mlet %store-monad ((_ (set-grafting #f)) + (nodes (mapm %store-monad (node-type-convert type) packages))) (export-graph (concatenate nodes) diff --git a/tests/grafts.scm b/tests/grafts.scm index 9fe314d183..4bc33709d6 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -17,12 +17,16 @@ ;;; along with GNU Guix. If not, see . (define-module (test-grafts) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (guix derivations) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix grafts) #:use-module (guix tests) #:use-module ((gnu packages) #:select (search-bootstrap-binary)) + #:use-module (gnu packages bootstrap) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) #:use-module (rnrs io ports)) @@ -42,7 +46,7 @@ (test-begin "grafts") -(test-assert "graft-derivation" +(test-assert "graft-derivation, grafted item is a direct dependency" (let* ((build `(begin (mkdir %output) (chdir %output) @@ -51,7 +55,7 @@ (lambda (output) (format output "foo/~a/bar" ,%mkdir))) (symlink ,%bash "sh"))) - (orig (build-expression->derivation %store "graft" build + (orig (build-expression->derivation %store "grafted" build #:inputs `(("a" ,%bash) ("b" ,%mkdir)))) (one (add-text-to-store %store "bash" "fake bash")) @@ -59,21 +63,80 @@ '(call-with-output-file %output (lambda (port) (display "fake mkdir" port))))) - (graft (graft-derivation %store orig - (list (graft - (origin %bash) - (replacement one)) - (graft - (origin %mkdir) - (replacement two)))))) - (and (build-derivations %store (list graft)) - (let ((two (derivation->output-path two)) - (graft (derivation->output-path graft))) + (grafted (graft-derivation %store orig + (list (graft + (origin %bash) + (replacement one)) + (graft + (origin %mkdir) + (replacement two)))))) + (and (build-derivations %store (list grafted)) + (let ((two (derivation->output-path two)) + (grafted (derivation->output-path grafted))) (and (string=? (format #f "foo/~a/bar" two) - (call-with-input-file (string-append graft "/text") + (call-with-input-file (string-append grafted "/text") get-string-all)) - (string=? (readlink (string-append graft "/sh")) one) - (string=? (readlink (string-append graft "/self")) graft)))))) + (string=? (readlink (string-append grafted "/sh")) one) + (string=? (readlink (string-append grafted "/self")) + grafted)))))) + +;; Make sure 'derivation-file-name' always gets to see an absolute file name. +(fluid-set! %file-port-name-canonicalization 'absolute) + +(test-assert "graft-derivation, grafted item is an indirect dependency" + (let* ((build `(begin + (mkdir %output) + (chdir %output) + (symlink %output "self") + (call-with-output-file "text" + (lambda (output) + (format output "foo/~a/bar" ,%mkdir))) + (symlink ,%bash "sh"))) + (dep (build-expression->derivation %store "dep" build + #:inputs `(("a" ,%bash) + ("b" ,%mkdir)))) + (orig (build-expression->derivation %store "thing" + '(symlink + (assoc-ref %build-inputs + "dep") + %output) + #:inputs `(("dep" ,dep)))) + (one (add-text-to-store %store "bash" "fake bash")) + (two (build-expression->derivation %store "mkdir" + '(call-with-output-file %output + (lambda (port) + (display "fake mkdir" port))))) + (grafted (graft-derivation %store orig + (list (graft + (origin %bash) + (replacement one)) + (graft + (origin %mkdir) + (replacement two)))))) + (and (build-derivations %store (list grafted)) + (let* ((two (derivation->output-path two)) + (grafted (derivation->output-path grafted)) + (dep (readlink grafted))) + (and (string=? (format #f "foo/~a/bar" two) + (call-with-input-file (string-append dep "/text") + get-string-all)) + (string=? (readlink (string-append dep "/sh")) one) + (string=? (readlink (string-append dep "/self")) dep) + (equal? (references %store grafted) (list dep)) + (lset= string=? + (list one two dep) + (references %store dep))))))) + +(test-assert "graft-derivation, no dependencies on grafted output" + (run-with-store %store + (mlet* %store-monad ((fake (text-file "bash" "Fake bash.")) + (graft -> (graft + (origin %bash) + (replacement fake))) + (drv (gexp->derivation "foo" #~(mkdir #$output))) + (grafted ((store-lift graft-derivation) drv + (list graft)))) + (return (eq? grafted drv))))) (test-assert "graft-derivation, multiple outputs" (let* ((build `(begin diff --git a/tests/packages.scm b/tests/packages.scm index 6315c2204f..46391783b0 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -605,23 +605,27 @@ (origin (package-derivation %store dep)) (replacement (package-derivation %store new))))))) -(test-assert "package-derivation, indirect grafts" - (let* ((new (dummy-package "dep" - (arguments '(#:implicit-inputs? #f)))) - (dep (package (inherit new) (version "0.0"))) - (dep* (package (inherit dep) (replacement new))) - (dummy (dummy-package "dummy" - (arguments '(#:implicit-inputs? #f)) - (inputs `(("dep" ,dep*))))) - (guile (package-derivation %store (canonical-package guile-2.0) - #:graft? #f))) - (equal? (package-derivation %store dummy) - (graft-derivation %store - (package-derivation %store dummy #:graft? #f) - (package-grafts %store dummy) - - ;; Use the same Guile as 'package-derivation'. - #:guile guile)))) +;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to +;;; find out about their run-time dependencies, so this test is no longer +;;; applicable since it would trigger a full rebuild. +;; +;; (test-assert "package-derivation, indirect grafts" +;; (let* ((new (dummy-package "dep" +;; (arguments '(#:implicit-inputs? #f)))) +;; (dep (package (inherit new) (version "0.0"))) +;; (dep* (package (inherit dep) (replacement new))) +;; (dummy (dummy-package "dummy" +;; (arguments '(#:implicit-inputs? #f)) +;; (inputs `(("dep" ,dep*))))) +;; (guile (package-derivation %store (canonical-package guile-2.0) +;; #:graft? #f))) +;; (equal? (package-derivation %store dummy) +;; (graft-derivation %store +;; (package-derivation %store dummy #:graft? #f) +;; (package-grafts %store dummy) + +;; ;; Use the same Guile as 'package-derivation'. +;; #:guile guile)))) (test-equal "package->bag" `("foo86-hurd" #f (,(package-source gnu-make)) -- cgit v1.2.3 From 1cbdf82d3ba5b257e44144788244139ae15689c8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 2 Mar 2016 13:25:50 +0100 Subject: guix archive: Use 'with-store'. * guix/scripts/archive.scm (guix-archive): Use 'with-store' instead of an explicit 'open-connection'. --- guix/scripts/archive.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 1a941d1a73..16ca96bdf5 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -324,7 +324,7 @@ the input port." ((assoc-ref opts 'authorize) (authorize-key)) (else - (let ((store (open-connection))) + (with-store store (cond ((assoc-ref opts 'export) (export-from-store store opts)) ((assoc-ref opts 'import) -- cgit v1.2.3 From 7573d30ff804302eeb68edeca6ae5f3efb48b7bf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 2 Mar 2016 13:43:13 +0100 Subject: guix build: Move '--no-grafts' to the common build options. * guix/scripts/build.scm (%options): Move --no-grafts to... (%standard-build-options): ... here. (show-help, show-build-options-help): Adjust accordingly. * guix/scripts/archive.scm (%default-options): Add 'graft?'. (guix-archive): Parametrize '%graft?'. * guix/scripts/environment.scm (%default-options): Add 'graft?'. (guix-environment): Parametrize '%graft?'. * guix/scripts/package.scm (%default-options): Add 'graft?'. (guix-package): Parametrize '%graft?'. * guix/scripts/system.scm (%default-options): Add 'graft?'. (guix-system): Parametrize 'graft?'. * doc/guix.texi (Additional Build Options): Move --no-grafts to... (Common Build Options): ... here. --- doc/guix.texi | 10 ++++----- guix/scripts/archive.scm | 51 +++++++++++++++++++++++--------------------- guix/scripts/build.scm | 14 ++++++------ guix/scripts/environment.scm | 8 ++++--- guix/scripts/package.scm | 5 ++++- guix/scripts/system.scm | 5 ++++- 6 files changed, 53 insertions(+), 40 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 5e62703380..44653efc6a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3912,6 +3912,11 @@ Do not use substitutes for build products. That is, always build things locally instead of allowing downloads of pre-built binaries (@pxref{Substitutes}). +@item --no-grafts +Do not ``graft'' packages. In practice, this means that package updates +available as grafts are not applied. @xref{Security Updates}, for more +information on grafts. + @item --rounds=@var{n} Build each derivation @var{n} times in a row, and raise an error if consecutive build results are not bit-for-bit identical. @@ -4175,11 +4180,6 @@ substitutes are genuine (@pxref{Substitutes}), or whether the build result of a package is deterministic. @xref{Invoking guix challenge}, for more background information and tools. -@item --no-grafts -Do not ``graft'' packages. In practice, this means that package updates -available as grafts are not applied. @xref{Security Updates}, for more -information on grafts. - @item --derivations @itemx -d Return the derivation paths, not the output paths, of the given diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 16ca96bdf5..3fb210ee91 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -22,6 +22,7 @@ #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (guix store) + #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix monads) @@ -50,6 +51,7 @@ ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) + (graft? . #t) (max-silent-time . 3600) (verbosity . 0))) @@ -318,27 +320,28 @@ the input port." ;; user to 'read-derivation' are absolute when it returns. (with-fluids ((%file-port-name-canonicalization 'absolute)) (let ((opts (parse-command-line args %options (list %default-options)))) - (cond ((assoc-ref opts 'generate-key) - => - generate-key-pair) - ((assoc-ref opts 'authorize) - (authorize-key)) - (else - (with-store store - (cond ((assoc-ref opts 'export) - (export-from-store store opts)) - ((assoc-ref opts 'import) - (import-paths store (current-input-port))) - ((assoc-ref opts 'missing) - (let* ((files (lines (current-input-port))) - (missing (remove (cut valid-path? store <>) - files))) - (format #t "~{~a~%~}" missing))) - ((assoc-ref opts 'extract) - => - (lambda (target) - (restore-file (current-input-port) target))) - (else - (leave - (_ "either '--export' or '--import' \ -must be specified~%"))))))))))) + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (cond ((assoc-ref opts 'generate-key) + => + generate-key-pair) + ((assoc-ref opts 'authorize) + (authorize-key)) + (else + (with-store store + (cond ((assoc-ref opts 'export) + (export-from-store store opts)) + ((assoc-ref opts 'import) + (import-paths store (current-input-port))) + ((assoc-ref opts 'missing) + (let* ((files (lines (current-input-port))) + (missing (remove (cut valid-path? store <>) + files))) + (format #t "~{~a~%~}" missing))) + ((assoc-ref opts 'extract) + => + (lambda (target) + (restore-file (current-input-port) target))) + (else + (leave + (_ "either '--export' or '--import' \ +must be specified~%")))))))))))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 8725ddad88..d6bb35c99a 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -295,6 +295,8 @@ options handled by 'set-build-options-from-command-line', and listed in (display (_ " --substitute-urls=URLS fetch substitute from URLS if they are authorized")) + (display (_ " + --no-grafts do not graft packages")) (display (_ " --no-build-hook do not attempt to offload builds via the build hook")) (display (_ " @@ -379,6 +381,12 @@ options handled by 'set-build-options-from-command-line', and listed in (string-tokenize arg) (alist-delete 'substitute-urls result)) rest))) + (option '("no-grafts") #f #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons 'graft? #f + (alist-delete 'graft? result eq?)) + rest))) (option '("no-build-hook") #f #f (lambda (opt name arg result . rest) (apply values @@ -451,8 +459,6 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) - (display (_ " - --no-grafts do not graft packages")) (display (_ " -d, --derivations return the derivation paths of the given packages")) (display (_ " @@ -531,10 +537,6 @@ must be one of 'package', 'all', or 'transitive'~%") (option '("log-file") #f #f (lambda (opt name arg result) (alist-cons 'log-file? #t result))) - (option '("no-grafts") #f #f - (lambda (opt name arg result) - (alist-cons 'graft? #f - (alist-delete 'graft? result eq?)))) (append %transformation-options %standard-build-options))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 0e462de4bf..b122b4cd40 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015 David Thompson -;;; Copyright © 2015 Ludovic Courtès +;;; Copyright © 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,6 +20,7 @@ (define-module (guix scripts environment) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) @@ -176,9 +177,9 @@ COMMAND or an interactive shell in that environment.\n")) (show-bug-report-information)) (define %default-options - ;; Default to opening a new shell. `((system . ,(%current-system)) (substitutes? . #t) + (graft? . #t) (max-silent-time . 3600) (verbosity . 0))) @@ -525,7 +526,8 @@ message if any test fails." (with-store store ;; Use the bootstrap Guile when requested. - (parameterize ((%guile-for-build + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build (package-derivation store (if bootstrap? diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index f65834386b..1d88b33996 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -22,6 +22,7 @@ (define-module (guix scripts package) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) @@ -319,6 +320,7 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." ;; Alist of default option values. `((max-silent-time . 3600) (verbosity . 0) + (graft? . #t) (substitutes? . #t))) (define (show-help) @@ -837,7 +839,8 @@ processed, #f otherwise." #:argument-handler handle-argument))) (with-error-handling (or (process-query opts) - (parameterize ((%store (open-connection))) + (parameterize ((%store (open-connection)) + (%graft? (assoc-ref opts 'graft?))) (set-build-options-from-command-line (%store) opts) (parameterize ((%guile-for-build diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 401aa8b60a..9f56a96ca0 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -21,6 +21,7 @@ #:use-module (guix config) #:use-module (guix ui) #:use-module (guix store) + #:use-module (guix grafts) #:use-module (guix gexp) #:use-module (guix derivations) #:use-module (guix packages) @@ -685,6 +686,7 @@ Build the operating system declared in FILE according to ACTION.\n")) ;; Alist of default option values. `((system . ,(%current-system)) (substitutes? . #t) + (graft? . #t) (build-hook? . #t) (max-silent-time . 3600) (verbosity . 0) @@ -812,6 +814,7 @@ argument list and OPTS is the option alist." parse-sub-command)) (args (option-arguments opts)) (command (assoc-ref opts 'action))) - (process-command command args opts)))) + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (process-command command args opts))))) ;;; system.scm ends here -- cgit v1.2.3 From 637cd1254320fd89fe6d910b3fa7665b19487072 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 2 Mar 2016 14:42:39 +0100 Subject: graph: Ignore 'GUIX_BUILD_OPTIONS'. Previously 'GUIX_BUILD_OPTIONS' would be honored, but 'guix graph' does not support the common build options. * guix/scripts/graph.scm (guix-graph): Use 'args-fold*' instead of 'parse-command-line'. --- guix/scripts/graph.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 2d1c1ff59f..b0d7c08582 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -341,8 +341,12 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (define (guix-graph . args) (with-error-handling - (let* ((opts (parse-command-line args %options - (list %default-options))) + (let* ((opts (args-fold* args %options + (lambda (opt name arg . rest) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) (type (assoc-ref opts 'node-type)) (packages (filter-map (match-lambda (('argument . spec) -- cgit v1.2.3 From 1b846da8c372bee78851439fd9e72b2499115e5a Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sun, 28 Feb 2016 23:11:36 +0100 Subject: utils: Use '@' for separating package names and version numbers. This provides the ability to use numbers in package names. Fixes . * guix/utils.scm (package-name->name+version): New procedure. * gnu/packages.scm (%find-package): Add a FALLBACK? keyword argument. Use the previous method when no package is found. (specification->package+output, specification->package): Adapt documentation to new syntax. * doc/guix.texi (Invoking guix package, Invoking guix import): Likewise. * guix/ui.scm (package-specification->name+version+output): Likewise. * guix/scripts/import/hackage.scm (show-help): Likewise. * tests/guix-build.sh: Adapt to new syntax. * tests/guix-lint.sh: Likewise. * tests/guix-package.sh: Likewise. * tests/ui.scm ("package-specification->name+version+output"): Likewise. * tests/utils.scm ("package-name->name+version"): Likewise. * NEWS: Mention new syntax. --- NEWS | 17 +++++++++++++++++ doc/guix.texi | 12 ++++++------ gnu/packages.scm | 18 +++++++++++++----- guix/scripts/import/hackage.scm | 2 +- guix/ui.scm | 4 ++-- guix/utils.scm | 15 ++++++++++++--- tests/guix-build.sh | 4 ++-- tests/guix-lint.sh | 2 +- tests/guix-package.sh | 4 ++-- tests/ui.scm | 6 +++--- tests/utils.scm | 5 +++-- 11 files changed, 62 insertions(+), 27 deletions(-) (limited to 'guix') diff --git a/NEWS b/NEWS index 010789e2e4..ec929909d7 100644 --- a/NEWS +++ b/NEWS @@ -14,18 +14,30 @@ Please send Guix bug reports to bug-guix@gnu.org. ** Package management +*** New syntax for separating package names and version numbers + +Use ‘@’ instead of ‘-’ as a separator, as in ‘gnupg@2.0’. This new separator +is a reserved character which is not allowed both in package names and version +numbers. + +The old syntax to specify a package’s version—e.g., as “gnupg-2.0”—is obsolete +and support for it will be removed in the future. + *** Emacs interface for licenses *** Emacs interface for system generations *** Emacs interface for hydra.gnu.org *** Changes in Emacs interface variables and faces + In the following names, BUFFER-TYPE means "info" or "list"; ENTRY-TYPE means "package", "output" or "generation". **** Removed + - guix-info-fill-column - guix-info-insert-ENTRY-TYPE-function **** Renamed + - guix-info-ignore-empty-vals -> guix-info-ignore-empty-values - guix-output-name-width -> guix-generation-output-name-width - guix-buffer-name-function -> guix-ui-buffer-name-function @@ -34,6 +46,7 @@ ENTRY-TYPE means "package", "output" or "generation". - guix-BUFFER-TYPE-file-path (face) -> guix-BUFFER-TYPE-file-name **** Replaced + - guix-list-column-format, guix-list-column-value-methods -> guix-ENTRY-TYPE-list-format - guix-info-displayed-params, guix-info-insert-methods, @@ -44,6 +57,10 @@ ENTRY-TYPE means "package", "output" or "generation". guix-ENTRY-TYPE-list-describe-warning-count - guix-package-info-fill-heading -> guix-info-fill +** Noteworthy bug fixes + +*** Numbers in package names are correctly handled (http://bugs.gnu.org/19219) + * Changes in 0.9.0 (since 0.8.3) ** Package management diff --git a/doc/guix.texi b/doc/guix.texi index 44653efc6a..082fe5a103 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -13,7 +13,7 @@ Copyright @copyright{} 2012, 2013, 2014, 2015, 2016 Ludovic Courtès@* Copyright @copyright{} 2013, 2014, 2016 Andreas Enge@* Copyright @copyright{} 2013 Nikita Karetnikov@* -Copyright @copyright{} 2015 Mathieu Lirzin@* +Copyright @copyright{} 2015, 2016 Mathieu Lirzin@* Copyright @copyright{} 2014 Pierre-Antoine Rault@* Copyright @copyright{} 2015 Taylan Ulrich Bayırlı/Kammer@* Copyright @copyright{} 2015, 2016 Leo Famulari @@ -1285,14 +1285,14 @@ The @var{options} can be among the following: Install the specified @var{package}s. Each @var{package} may specify either a simple package name, such as -@code{guile}, or a package name followed by a hyphen and version number, -such as @code{guile-1.8.8} or simply @code{guile-1.8} (in the latter +@code{guile}, or a package name followed by an at-sign and version number, +such as @code{guile@@1.8.8} or simply @code{guile@@1.8} (in the latter case, the newest version prefixed by @code{1.8} is selected.) If no version number is specified, the newest available version will be selected. In addition, @var{package} may contain a colon, followed by the name of one of the outputs of the -package, as in @code{gcc:doc} or @code{binutils-2.22:lib} +package, as in @code{gcc:doc} or @code{binutils@@2.22:lib} (@pxref{Packages with Multiple Outputs}). Packages with a corresponding name (and optionally version) are searched for among the GNU distribution modules (@pxref{Package Modules}). @@ -4522,10 +4522,10 @@ guix import hackage -t -e "'((\"network-uri\" . false))" HTTP @end example A specific package version may optionally be specified by following the -package name by a hyphen and a version number as in the following example: +package name by an at-sign and a version number as in the following example: @example -guix import hackage mtl-2.1.3.1 +guix import hackage mtl@@2.1.3.1 @end example @item elpa diff --git a/gnu/packages.scm b/gnu/packages.scm index 9b111eda28..272a7628c1 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -282,7 +282,7 @@ return its return value." ;;; Package specification. ;;; -(define (%find-package spec name version) +(define* (%find-package spec name version #:key fallback?) (match (find-best-packages-by-name name version) ((pkg . pkg*) (unless (null? pkg*) @@ -290,15 +290,23 @@ return its return value." (warning (_ "choosing ~a from ~a~%") (package-full-name pkg) (location->string (package-location pkg)))) + (when fallback? + (warning (_ "deprecated NAME-VERSION syntax.~%"))) pkg) (_ (if version (leave (_ "~A: package not found for version ~a~%") name version) - (leave (_ "~A: unknown package~%") name))))) + (or fallback? + ;; XXX: Fallback to the older specification style with an hyphen + ;; between NAME and VERSION, for backward compatibility. + (let ((proc (@ (guix build utils) package-name->name+version))) + (call-with-values (proc name) + (cut %find-package spec <> <> #:fallback? #t))) + (leave (_ "~A: unknown package~%") name)))))) (define (specification->package spec) "Return a package matching SPEC. SPEC may be a package name, or a package -name followed by a hyphen and a version number. If the version number is not +name followed by an at-sign and a version number. If the version number is not present, return the preferred newest version." (let-values (((name version) (package-name->name+version spec))) (%find-package spec name version))) @@ -308,9 +316,9 @@ present, return the preferred newest version." optionally contain a version number and an output name, as in these examples: guile - guile-2.0.9 + guile@2.0.9 guile:debug - guile-2.0.9:debug + guile@2.0.9:debug If SPEC does not specify a version number, return the preferred newest version; if SPEC does not specify an output, return OUTPUT." diff --git a/guix/scripts/import/hackage.scm b/guix/scripts/import/hackage.scm index 4e84278a78..f2c20026b6 100644 --- a/guix/scripts/import/hackage.scm +++ b/guix/scripts/import/hackage.scm @@ -46,7 +46,7 @@ (define (show-help) (display (_ "Usage: guix import hackage PACKAGE-NAME Import and convert the Hackage package for PACKAGE-NAME. If PACKAGE-NAME -includes a suffix constituted by a dash followed by a numerical version (as +includes a suffix constituted by a at-sign followed by a numerical version (as used with Guix packages), then a definition for the specified version of the package will be generated. If no version suffix is pecified, then the generated package definition will correspond to the latest available diff --git a/guix/ui.scm b/guix/ui.scm index 7310773310..a3ec6834b6 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1081,9 +1081,9 @@ package name, version number (or #f), and output name (or OUTPUT). SPEC may optionally contain a version number and an output name, as in these examples: guile - guile-2.0.9 + guile@2.0.9 guile:debug - guile-2.0.9:debug + guile@2.0.9:debug " (let*-values (((name sub-drv) (match (string-rindex spec #\:) diff --git a/guix/utils.scm b/guix/utils.scm index c61f105513..de541799fa 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2013, 2014, 2015 Mark H Weaver ;;; Copyright © 2014 Eric Bavier ;;; Copyright © 2014 Ian Denhardt +;;; Copyright © 2016 Mathieu Lirzin ;;; Copyright © 2015 David Thompson ;;; ;;; This file is part of GNU Guix. @@ -31,8 +32,7 @@ #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) - #:use-module ((guix build utils) - #:select (dump-port package-name->name+version)) + #:use-module ((guix build utils) #:select (dump-port)) #:use-module ((guix build syscalls) #:select (errno mkdtemp!)) #:use-module (ice-9 vlist) #:use-module (ice-9 format) @@ -42,7 +42,6 @@ #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (system foreign) - #:re-export (package-name->name+version) #:export (bytevector->base16-string base16-string->bytevector @@ -66,6 +65,7 @@ gnu-triplet->nix-system %current-system %current-target-system + package-name->name+version version-compare version>? version>=? @@ -544,6 +544,15 @@ returned by `config.guess'." ;; cross-building to. (make-parameter #f)) +(define (package-name->name+version spec) + "Given SPEC, a package name like \"foo@0.9.1b\", return two values: \"foo\" +and \"0.9.1b\". When the version part is unavailable, SPEC and #f are +returned. Both parts must not contain any '@'." + (match (string-rindex spec #\@) + (#f (values spec #f)) + (idx (values (substring spec 0 idx) + (substring spec (1+ idx)))))) + (define version-compare (let ((strverscmp (let ((sym (or (dynamic-func "strverscmp" (dynamic-link)) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 778911b2f8..5821e509af 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -161,8 +161,8 @@ then false; else true; fi # Parsing package names and versions. guix build -n time # PASS -guix build -n time-1.7 # PASS, version found -if guix build -n time-3.2; # FAIL, version not found +guix build -n time@1.7 # PASS, version found +if guix build -n time@3.2; # FAIL, version not found then false; else true; fi if guix build -n something-that-will-never-exist; # FAIL then false; else true; fi diff --git a/tests/guix-lint.sh b/tests/guix-lint.sh index 5015b5cfb5..c105521ec7 100644 --- a/tests/guix-lint.sh +++ b/tests/guix-lint.sh @@ -75,4 +75,4 @@ if guix lint -c synopsis,invalid-checker dummy 2>&1 | \ then true; else false; fi # Make sure specifying multiple packages works. -guix lint -c inputs-should-be-native dummy dummy-42 dummy +guix lint -c inputs-should-be-native dummy dummy@42 dummy diff --git a/tests/guix-package.sh b/tests/guix-package.sh index d75008448b..28c34dbc6a 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -207,13 +207,13 @@ cat > "$module_dir/foo.scm"< "$module_dir/emacs.patch"<name+version+output spec)) list)) '("guile" - "guile-2.0.9" + "guile@2.0.9" "guile:debug" - "guile-2.0.9:debug" - "guile-cairo-1.4.1"))) + "guile@2.0.9:debug" + "guile-cairo@1.4.1"))) (test-equal "integer" '(1) diff --git a/tests/utils.scm b/tests/utils.scm index a05faabc15..67b3724451 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2014 Eric Bavier +;;; Copyright © 2016 Mathieu Lirzin ;;; ;;; This file is part of GNU Guix. ;;; @@ -59,14 +60,14 @@ ((name version) (let*-values (((full-name) (if version - (string-append name "-" version) + (string-append name "@" version) name)) ((name* version*) (package-name->name+version full-name))) (and (equal? name* name) (equal? version* version))))) '(("foo" "0.9.1b") - ("foo-bar" "1.0") + ("foo-14-bar" "320") ("foo-bar2" #f) ("guile" "2.0.6.65-134c9") ; as produced by `git-version-gen' ("nixpkgs" "1.0pre22125_a28fe19") -- cgit v1.2.3 From 94d609aba8e14963459c21863ab56da2b5f01517 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 2 Mar 2016 23:57:23 +0100 Subject: guix build: -S returns the replacement's source. Reported by Mark H Weaver. * guix/scripts/build.scm (options->derivations): When SRC and GRAFT? are true, use the source of P's replacement. * tests/guix-build.sh: Add test. --- guix/scripts/build.scm | 19 ++++++++++--------- tests/guix-build.sh | 9 +++++++++ 2 files changed, 19 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index d6bb35c99a..a8becea2de 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -592,15 +592,16 @@ build." (parameterize ((%graft? graft?)) (append-map (match-lambda ((? package? p) - (match src - (#f - (list (package->derivation store p system))) - (#t - (let ((s (package-source p))) - (list (package-source-derivation store s)))) - (proc - (map (cut package-source-derivation store <>) - (proc p))))) + (let ((p (or (and graft? (package-replacement p)) p))) + (match src + (#f + (list (package->derivation store p system))) + (#t + (let ((s (package-source p))) + (list (package-source-derivation store s)))) + (proc + (map (cut package-source-derivation store <>) + (proc p)))))) ((? derivation? drv) (list drv)) ((? procedure? proc) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 5821e509af..ae75bcfab0 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -43,6 +43,7 @@ trap "rm -rf $module_dir" EXIT cat > "$module_dir/foo.scm"< "$module_dir/foo.scm"< Date: Thu, 3 Mar 2016 09:45:09 +0100 Subject: lint: derivation: Disable grafts, but check replacements. * guix/scripts/lint.scm (check-derivation): Pass #:graft? #f. When 'package-replacement' exists, compute its derivation. --- guix/scripts/lint.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index e729398742..8876704d4d 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -551,7 +551,15 @@ descriptions maintained upstream." (format #f (_ "failed to create derivation: ~a") (condition-message c))))) (with-store store - (package-derivation store package)))) + ;; Disable grafts since it can entail rebuilds. + (package-derivation store package #:graft? #f) + + ;; If there's a replacement, make sure we can compute its + ;; derivation. + (match (package-replacement package) + (#f #t) + (replacement + (package-derivation store replacement #:graft? #f)))))) (lambda args (emit-warning package (format #f (_ "failed to create derivation: ~s~%") -- cgit v1.2.3 From 4ce783a2f9edc5cf1024b02e3c434ed361e8897d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 4 Mar 2016 10:44:08 +0100 Subject: lint: cve: Gracefully handle HTTP errors. * guix/scripts/lint.scm (current-vulnerabilities*): New procedure. (package-vulnerabilities): Use it. --- guix/scripts/lint.scm | 33 +++++++++++++++++++++++---------- 1 file changed, 23 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 8876704d4d..f135bde9df 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -24,6 +24,7 @@ #:use-module (guix base32) #:use-module (guix download) #:use-module (guix ftp-client) + #:use-module (guix http-client) #:use-module (guix packages) #:use-module (guix licenses) #:use-module (guix records) @@ -593,18 +594,30 @@ Common Platform Enumeration (CPE) name." ;; TODO: Add more. (_ name))) +(define (current-vulnerabilities*) + "Like 'current-vulnerabilities', but return the empty list upon networking +or HTTP errors. This allows network-less operation and makes problems with +the NIST server non-fatal.." + (guard (c ((http-get-error? c) + (warning (_ "failed to retrieve CVE vulnerabilities \ +from ~s: ~a (~s)~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + (warning (_ "assuming no CVE vulnerabilities~%")) + '())) + (catch 'getaddrinfo-error + (lambda () + (current-vulnerabilities)) + (lambda (key errcode) + (warning (_ "failed to lookup NIST host: ~a~%") + (gai-strerror errcode)) + (warning (_ "assuming no CVE vulnerabilities~%")) + '())))) + (define package-vulnerabilities (let ((lookup (delay (vulnerabilities->lookup-proc - ;; Catch networking errors to allow network-less - ;; operation. - (catch 'getaddrinfo-error - (lambda () - (current-vulnerabilities)) - (lambda (key errcode) - (warn (_ "failed to lookup NIST host: ~a~%") - (gai-strerror errcode)) - (warn (_ "assuming no CVE vulnerabilities~%")) - '())))))) + (current-vulnerabilities*))))) (lambda (package) "Return a list of vulnerabilities affecting PACKAGE." ((force lookup) -- cgit v1.2.3 From c8f9f24776040cc5645cf3b91b19946b1f1e4dac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 4 Mar 2016 17:50:30 +0100 Subject: guix build: Set the build options early. This fixes a bug whereby, with grafts leading to builds very early, build options such as --substitute-urls would not be taken into account yet. Reported by Andreas Enge . * guix/scripts/build.scm (guix-build): Move 'opts' to the beginning. Use 'with-store' instead of 'open-connection'. Call 'set-build-options-from-command-line' right after 'with-store'. --- guix/scripts/build.scm | 98 ++++++++++++++++++++++++++------------------------ 1 file changed, 51 insertions(+), 47 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index a8becea2de..3607d78537 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -634,55 +634,59 @@ needed." ;;; (define (guix-build . args) + (define opts + (parse-command-line args %options + (list %default-options))) + (with-error-handling ;; Ask for absolute file names so that .drv file names passed from the ;; user to 'read-derivation' are absolute when it returns. (with-fluids ((%file-port-name-canonicalization 'absolute)) - (let* ((opts (parse-command-line args %options - (list %default-options))) - (store (open-connection)) - (mode (assoc-ref opts 'build-mode)) - (drv (options->derivations store opts)) - (urls (map (cut string-append <> "/log") - (if (assoc-ref opts 'substitutes?) - (or (assoc-ref opts 'substitute-urls) - ;; XXX: This does not necessarily match the - ;; daemon's substitute URLs. - %default-substitute-urls) - '()))) - (items (filter-map (match-lambda - (('argument . (? store-path? file)) - file) - (_ #f)) - opts)) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) - opts))) - + (with-store store + ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) - (unless (assoc-ref opts 'log-file?) - (show-what-to-build store drv - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?) - #:mode mode)) - - (cond ((assoc-ref opts 'log-file?) - (for-each (cut show-build-log store <> urls) - (delete-duplicates - (append (map derivation-file-name drv) - items)))) - ((assoc-ref opts 'derivations-only?) - (format #t "~{~a~%~}" (map derivation-file-name drv)) - (for-each (cut register-root store <> <>) - (map (compose list derivation-file-name) drv) - roots)) - ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations store drv mode) - (for-each show-derivation-outputs drv) - (for-each (cut register-root store <> <>) - (map (lambda (drv) - (map cdr - (derivation->output-paths drv))) - drv) - roots)))))))) + + (let* ((mode (assoc-ref opts 'build-mode)) + (drv (options->derivations store opts)) + (urls (map (cut string-append <> "/log") + (if (assoc-ref opts 'substitutes?) + (or (assoc-ref opts 'substitute-urls) + ;; XXX: This does not necessarily match the + ;; daemon's substitute URLs. + %default-substitute-urls) + '()))) + (items (filter-map (match-lambda + (('argument . (? store-path? file)) + file) + (_ #f)) + opts)) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) + + (unless (assoc-ref opts 'log-file?) + (show-what-to-build store drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?) + #:mode mode)) + + (cond ((assoc-ref opts 'log-file?) + (for-each (cut show-build-log store <> urls) + (delete-duplicates + (append (map derivation-file-name drv) + items)))) + ((assoc-ref opts 'derivations-only?) + (format #t "~{~a~%~}" (map derivation-file-name drv)) + (for-each (cut register-root store <> <>) + (map (compose list derivation-file-name) drv) + roots)) + ((not (assoc-ref opts 'dry-run?)) + (and (build-derivations store drv mode) + (for-each show-derivation-outputs drv) + (for-each (cut register-root store <> <>) + (map (lambda (drv) + (map cdr + (derivation->output-paths drv))) + drv) + roots))))))))) -- cgit v1.2.3 From 7bfeb9df20906fd80c91fecccac3f56d0da05238 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 4 Mar 2016 17:57:49 +0100 Subject: tests: Narinfos can specify an non-empty reference list. * guix/tests.scm (derivation-narinfo): Add #:references and honor it. (call-with-derivation-narinfo, call-with-derivation-substitute): Likewise. (with-derivation-narinfo, with-derivation-substitute): Add 'references' keyword. --- guix/tests.scm | 51 +++++++++++++++++++++++++++++++++++---------------- 1 file changed, 35 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/tests.scm b/guix/tests.scm index 80c174509d..3cb4a671af 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -132,21 +132,23 @@ given by REPLACEMENT." ;;; (define* (derivation-narinfo drv #:key (nar "example.nar") - (sha256 (make-bytevector 32 0))) - "Return the contents of the narinfo corresponding to DRV; NAR should be the -file name of the archive containing the substitute for DRV, and SHA256 is the -expected hash." + (sha256 (make-bytevector 32 0)) + (references '())) + "Return the contents of the narinfo corresponding to DRV, with the specified +REFERENCES (a list of store items); NAR should be the file name of the archive +containing the substitute for DRV, and SHA256 is the expected hash." (format #f "StorePath: ~a URL: ~a Compression: none NarSize: 1234 NarHash: sha256:~a -References: +References: ~a System: ~a Deriver: ~a~%" (derivation->output-path drv) ; StorePath nar ; URL (bytevector->nix-base32-string sha256) ; NarHash + (string-join (map basename references)) ; References (derivation-system drv) ; System (basename (derivation-file-name drv)))) ; Deriver @@ -157,7 +159,9 @@ Deriver: ~a~%" (compose uri-path string->uri)))) (define* (call-with-derivation-narinfo drv thunk - #:key (sha256 (make-bytevector 32 0))) + #:key + (sha256 (make-bytevector 32 0)) + (references '())) "Call THUNK in a context where fake substituter data, as read by 'guix substitute', has been installed for DRV. SHA256 is the hash of the expected output of DRV." @@ -174,27 +178,36 @@ expected output of DRV." (%store-prefix)))) (call-with-output-file narinfo (lambda (p) - (display (derivation-narinfo drv #:sha256 sha256) p)))) + (display (derivation-narinfo drv #:sha256 sha256 + #:references references) + p)))) thunk (lambda () (delete-file narinfo) (delete-file info))))) (define-syntax with-derivation-narinfo - (syntax-rules (sha256 =>) + (syntax-rules (sha256 references =>) "Evaluate BODY in a context where DRV looks substitutable from the substituter's viewpoint." - ((_ drv (sha256 => hash) body ...) + ((_ drv (sha256 => hash) (references => refs) body ...) (call-with-derivation-narinfo drv (lambda () body ...) - #:sha256 hash)) + #:sha256 hash + #:references refs)) + ((_ drv (sha256 => hash) body ...) + (with-derivation-narinfo drv + (sha256 => hash) (references => '()) + body ...)) ((_ drv body ...) (call-with-derivation-narinfo drv (lambda () body ...))))) (define* (call-with-derivation-substitute drv contents thunk - #:key sha256) + #:key + sha256 + (references '())) "Call THUNK in a context where a substitute for DRV has been installed, using CONTENTS, a string, as its contents. If SHA256 is true, use it as the expected hash of the substitute; otherwise use the hash of the nar containing @@ -214,7 +227,8 @@ CONTENTS." ;; Create fake substituter data, to be read by 'guix substitute'. (call-with-derivation-narinfo drv thunk - #:sha256 (or sha256 hash)))) + #:sha256 (or sha256 hash) + #:references references))) (lambda () (delete-file (string-append dir "/example.out")) (delete-file (string-append dir "/example.nar"))))) @@ -231,13 +245,18 @@ all included." (> (string-length shebang) 128)) (define-syntax with-derivation-substitute - (syntax-rules (sha256 =>) + (syntax-rules (sha256 references =>) "Evaluate BODY in a context where DRV is substitutable with the given CONTENTS." - ((_ drv contents (sha256 => hash) body ...) + ((_ drv contents (sha256 => hash) (references => refs) body ...) (call-with-derivation-substitute drv contents (lambda () body ...) - #:sha256 hash)) + #:sha256 hash + #:references refs)) + ((_ drv contents (sha256 => hash) body ...) + (with-derivation-substitute drv contents + (sha256 => hash) (references => '()) + body ...)) ((_ drv contents body ...) (call-with-derivation-substitute drv contents (lambda () -- cgit v1.2.3 From 6581ec9ab9ccb82cf1ddd7cf78c02975954bf8bf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 4 Mar 2016 17:57:04 +0100 Subject: store: Add 'references/substitutes'. * guix/store.scm (references/substitutes): New procedure. * tests/store.scm ("references/substitutes missing reference info") ("references/substitutes with substitute info"): New tests. --- guix/store.scm | 41 +++++++++++++++++++++++++++++++++++++++++ tests/store.scm | 35 +++++++++++++++++++++++++++++++++++ 2 files changed, 76 insertions(+) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 8746d3c2d6..56aa38ba8d 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -27,6 +27,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -93,6 +94,7 @@ path-info-nar-size references + references/substitutes requisites referrers optimize-store @@ -724,6 +726,45 @@ error if there is no such root." "Return the list of references of PATH." store-path-list)) +(define (references/substitutes store items) + "Return the list of list of references of ITEMS; the result has the same +length as ITEMS. Query substitute information for any item missing from the +store at once. Raise a '&nix-protocol-error' exception if reference +information for one of ITEMS is missing." + (let* ((local-refs (map (lambda (item) + (guard (c ((nix-protocol-error? c) #f)) + (references store item))) + items)) + (missing (fold-right (lambda (item local-ref result) + (if local-ref + result + (cons item result))) + '() + items local-refs)) + + ;; Query all the substitutes at once to minimize the cost of + ;; launching 'guix substitute' and making HTTP requests. + (substs (substitutable-path-info store missing))) + (when (< (length substs) (length missing)) + (raise (condition (&nix-protocol-error + (message "cannot determine \ +the list of references") + (status 1))))) + + ;; Intersperse SUBSTS and LOCAL-REFS. + (let loop ((local-refs local-refs) + (remote-refs (map substitutable-references substs)) + (result '())) + (match local-refs + (() + (reverse result)) + ((#f tail ...) + (match remote-refs + ((remote rest ...) + (loop tail rest (cons remote result))))) + ((head tail ...) + (loop tail remote-refs (cons head result))))))) + (define* (fold-path store proc seed path #:optional (relatives (cut references store <>))) "Call PROC for each of the RELATIVES of PATH, exactly once, and return the diff --git a/tests/store.scm b/tests/store.scm index de070eab23..3d32d52758 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -196,6 +196,41 @@ (null? (references %store t1)) (null? (referrers %store t2))))) +(test-assert "references/substitutes missing reference info" + (with-store s + (set-build-options s #:use-substitutes? #f) + (guard (c ((nix-protocol-error? c) #t)) + (let* ((b (add-to-store s "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d (derivation s "the-thing" b '("--help") + #:inputs `((,b))))) + (references/substitutes s (list (derivation->output-path d) b)))))) + +(test-assert "references/substitutes with substitute info" + (with-store s + (set-build-options s #:use-substitutes? #t) + (let* ((t1 (add-text-to-store s "random1" (random-text))) + (t2 (add-text-to-store s "random2" (random-text) + (list t1))) + (t3 (add-text-to-store s "build" "echo -n $t2 > $out")) + (b (add-to-store s "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d (derivation s "the-thing" b `("-e" ,t3) + #:inputs `((,b) (,t3) (,t2)) + #:env-vars `(("t2" . ,t2)))) + (o (derivation->output-path d))) + (with-derivation-narinfo d + (sha256 => (sha256 (string->utf8 t2))) + (references => (list t2)) + + (equal? (references/substitutes s (list o t3 t2 t1)) + `((,t2) ;refs of O + () ;refs of T3 + (,t1) ;refs of T2 + ())))))) ;refs of T1 + (test-assert "requisites" (let* ((t1 (add-text-to-store %store "random1" (random-text) '())) -- cgit v1.2.3 From c90cb5c9d84ded26ef44d1e6593508d5b9e4655e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 4 Mar 2016 21:49:08 +0100 Subject: grafts: Use dependency information from substitutes when possible. This avoids starting derivation builds just for the sake of knowing the references of their outputs, thereby restoring the expected behavior of --dry-run when substitutes are available. * guix/grafts.scm (non-self-references): Remove 'store' parameter, and add 'references'. Use it. Update caller. (references-oracle): New variable. (cumulative-grafts): Add 'references' parameter and use it. Update callers. (graft-derivation): Remove 'build-derivations' call. Add call to 'references-oracle'. --- guix/grafts.scm | 63 ++++++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 51 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index 9bcc5e2ef8..eca0a9fcad 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -26,7 +26,9 @@ #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (ice-9 match) + #:use-module (ice-9 vlist) #:export (graft? graft graft-origin @@ -162,36 +164,71 @@ name of the output of that derivation ITEM corresponds to (for example (and (string=? item path) name))) (derivation->output-paths drv))))))) -(define (non-self-references store drv outputs) +(define (non-self-references references drv outputs) "Return the list of references of the OUTPUTS of DRV, excluding self -references." - (let ((refs (append-map (lambda (output) - (references store - (derivation->output-path drv output))) +references. Call REFERENCES to get the list of references." + (let ((refs (append-map (compose references + (cut derivation->output-path drv <>)) outputs)) (self (match (derivation->output-paths drv) (((names . items) ...) items)))) (remove (cut member <> self) refs))) +(define (references-oracle store drv) + "Return a one-argument procedure that, when passed the file name of DRV's +outputs or their dependencies, returns the list of references of that item. +Use either local info or substitute info; build DRV if no information is +available." + (define (output-paths drv) + (match (derivation->output-paths drv) + (((names . items) ...) + items))) + + (define (references* items) + (guard (c ((nix-protocol-error? c) + ;; As a last resort, build DRV and query the references of the + ;; build result. + (and (build-derivations store (list drv)) + (map (cut references store <>) items)))) + (references/substitutes store items))) + + (let loop ((items (output-paths drv)) + (result vlist-null)) + (match items + (() + (lambda (item) + (match (vhash-assoc item result) + ((_ . refs) refs) + (#f #f)))) + (_ + (let* ((refs (references* items)) + (result (fold vhash-cons result items refs))) + (loop (remove (cut vhash-assoc <> result) + (delete-duplicates (concatenate refs) string=?)) + result)))))) + (define* (cumulative-grafts store drv grafts + references #:key (outputs (derivation-output-names drv)) (guile (%guile-for-build)) (system (%current-system))) "Augment GRAFTS with additional grafts resulting from the application of -GRAFTS to the dependencies of DRV. Return the resulting list of grafts." +GRAFTS to the dependencies of DRV; REFERENCES must be a one-argument procedure +that returns the list of references of the store item it is given. Return the +resulting list of grafts." (define (dependency-grafts item) (let-values (((drv output) (item->deriver store item))) (if drv - (cumulative-grafts store drv grafts + (cumulative-grafts store drv grafts references #:outputs (list output) #:guile guile #:system system) grafts))) ;; TODO: Memoize. - (match (non-self-references store drv outputs) + (match (non-self-references references drv outputs) (() ;no dependencies grafts) (deps ;one or more dependencies @@ -213,11 +250,13 @@ GRAFTS to the dependencies of DRV. Return the resulting list of grafts." GRAFTS apply only indirectly to DRV, graft the dependencies of DRV, and graft DRV itself to refer to those grafted dependencies." - ;; First, we need to build the ungrafted DRV so we can query its run-time - ;; dependencies in 'cumulative-grafts'. - (build-derivations store (list drv)) + ;; First, pre-compute the dependency tree of the outputs of DRV. Do this + ;; upfront to have as much parallelism as possible when querying substitute + ;; info or when building DRV. + (define references + (references-oracle store drv)) - (match (cumulative-grafts store drv grafts + (match (cumulative-grafts store drv grafts references #:guile guile #:system system) ((first . rest) ;; If FIRST is not a graft for DRV, it means that GRAFTS are not -- cgit v1.2.3 From fcadd9ff9dfd57c4d386287477e665d4efe9090d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 4 Mar 2016 23:01:47 +0100 Subject: packages: The result of 'bag-grafts' does not contain duplicates. * guix/packages.scm (bag-grafts): Add call to 'delete-duplicates'. --- guix/packages.scm | 7 ++++++- tests/packages.scm | 25 +++++++++++++++++++++++++ 2 files changed, 31 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 3e50260069..1769238b5e 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -927,7 +927,12 @@ to (see 'graft-derivation'.)" #:native? #f)) '())) - (append native-grafts target-grafts)) + ;; We can end up with several identical grafts if we stumble upon packages + ;; that are not 'eq?' but map to the same derivation (this can happen when + ;; using things like 'package-with-explicit-inputs'.) Hence the + ;; 'delete-duplicates' call. + (delete-duplicates + (append native-grafts target-grafts))) (define* (package-grafts store package #:optional (system (%current-system)) diff --git a/tests/packages.scm b/tests/packages.scm index 46391783b0..f7af5d4bb5 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -20,6 +20,7 @@ #:use-module (guix tests) #:use-module (guix store) #:use-module (guix monads) + #:use-module (guix grafts) #:use-module ((guix utils) ;; Rename the 'location' binding to allow proper syntax ;; matching when setting the 'location' field of a package. @@ -605,6 +606,30 @@ (origin (package-derivation %store dep)) (replacement (package-derivation %store new))))))) +(test-assert "package-grafts, same replacement twice" + (let* ((new (dummy-package "dep" + (version "1") + (arguments '(#:implicit-inputs? #f)))) + (dep (package (inherit new) (version "0") (replacement new))) + (p1 (dummy-package "intermediate1" + (arguments '(#:implicit-inputs? #f)) + (inputs `(("dep" ,dep))))) + (p2 (dummy-package "intermediate2" + (arguments '(#:implicit-inputs? #f)) + ;; Here we copy DEP to have an equivalent package that is not + ;; 'eq?' to DEP. This is similar to what happens with + ;; 'package-with-explicit-inputs' & co. + (inputs `(("dep" ,(package (inherit dep))))))) + (p3 (dummy-package "final" + (arguments '(#:implicit-inputs? #f)) + (inputs `(("p1" ,p1) ("p2" ,p2)))))) + (equal? (package-grafts %store p3) + (list (graft + (origin (package-derivation %store + (package (inherit dep) + (replacement #f)))) + (replacement (package-derivation %store new))))))) + ;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to ;;; find out about their run-time dependencies, so this test is no longer ;;; applicable since it would trigger a full rebuild. -- cgit v1.2.3 From d4da602e4c28d704ee04ec57887fa14b134c7ebb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 4 Mar 2016 23:10:28 +0100 Subject: grafts: Memoize intermediate results in 'cumulative-grafts'. The time for: guix build inkscape -n --no-substitutes goes down by 30% (in the presence of 3 replacements among all the packages.) * guix/grafts.scm (cumulative-grafts): Turn into a monadic procedure in %STATE-MONAD. Use the current state as a derivation-to-graft cache. (graft-derivation): Call 'cumulative-grafts' within 'run-with-state'. --- guix/grafts.scm | 54 +++++++++++++++++++++++++++++++++++------------------- 1 file changed, 35 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index eca0a9fcad..af469575db 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -217,7 +217,10 @@ available." "Augment GRAFTS with additional grafts resulting from the application of GRAFTS to the dependencies of DRV; REFERENCES must be a one-argument procedure that returns the list of references of the store item it is given. Return the -resulting list of grafts." +resulting list of grafts. + +This is a monadic procedure in %STATE-MONAD where the state is a vhash mapping +derivations to the corresponding set of grafts." (define (dependency-grafts item) (let-values (((drv output) (item->deriver store item))) (if drv @@ -225,23 +228,34 @@ resulting list of grafts." #:outputs (list output) #:guile guile #:system system) - grafts))) + (state-return grafts)))) + + (define (return/cache cache value) + (mbegin %store-monad + (set-current-state (vhash-consq drv value cache)) + (return value))) - ;; TODO: Memoize. - (match (non-self-references references drv outputs) - (() ;no dependencies - grafts) - (deps ;one or more dependencies - (let* ((grafts (delete-duplicates (append-map dependency-grafts deps) - eq?)) - (origins (map graft-origin-file-name grafts))) - (if (find (cut member <> deps) origins) - (let ((new (graft-derivation/shallow store drv grafts - #:guile guile - #:system system))) - (cons (graft (origin drv) (replacement new)) - grafts)) - grafts))))) + (mlet %state-monad ((cache (current-state))) + (match (vhash-assq drv cache) + ((_ . grafts) ;hit + (return grafts)) + (#f ;miss + (match (non-self-references references drv outputs) + (() ;no dependencies + (return/cache cache grafts)) + (deps ;one or more dependencies + (mlet %state-monad ((grafts (mapm %state-monad dependency-grafts deps)) + (cache (current-state))) + (let* ((grafts (delete-duplicates (concatenate grafts) equal?)) + (origins (map graft-origin-file-name grafts))) + (if (find (cut member <> deps) origins) + (let* ((new (graft-derivation/shallow store drv grafts + #:guile guile + #:system system)) + (grafts (cons (graft (origin drv) (replacement new)) + grafts))) + (return/cache cache grafts)) + (return/cache cache grafts)))))))))) (define* (graft-derivation store drv grafts #:key (guile (%guile-for-build)) @@ -256,8 +270,10 @@ DRV itself to refer to those grafted dependencies." (define references (references-oracle store drv)) - (match (cumulative-grafts store drv grafts references - #:guile guile #:system system) + (match (run-with-state + (cumulative-grafts store drv grafts references + #:guile guile #:system system) + vlist-null) ;the initial cache ((first . rest) ;; If FIRST is not a graft for DRV, it means that GRAFTS are not ;; applicable to DRV and nothing needs to be done. -- cgit v1.2.3 From dd78e90a4dcd1e637b56ae278c4e631ccb384ee0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Mar 2016 22:01:33 +0100 Subject: store: 'references/substitutes' correctly handles the order of substitutes. Before that, 'references/substitutes' would assume that 'substitutable-path-info' would return things in the same order as its arguments, which is not the case. Thus, it would sometimes provide incorrect reference information, occasionally leading to infinite loop (because dependency information would denote cycles.) Fixes . Reported by Eric Bavier . * guix/store.scm (references/substitutes): Make ITEMS the first argument of the loop; match on it. Use 'any' to find a matching substitute. (substitutable-path-info): Clarify docstring about ordering. --- guix/store.scm | 28 ++++++++++++++++++---------- 1 file changed, 18 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 56aa38ba8d..a220b6e6f9 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -752,18 +752,24 @@ the list of references") (status 1))))) ;; Intersperse SUBSTS and LOCAL-REFS. - (let loop ((local-refs local-refs) - (remote-refs (map substitutable-references substs)) + (let loop ((items items) + (local-refs local-refs) (result '())) - (match local-refs + (match items (() (reverse result)) - ((#f tail ...) - (match remote-refs - ((remote rest ...) - (loop tail rest (cons remote result))))) - ((head tail ...) - (loop tail remote-refs (cons head result))))))) + ((item items ...) + (match local-refs + ((#f tail ...) + (loop items tail + (cons (any (lambda (subst) + (and (string=? (substitutable-path subst) item) + (substitutable-references subst))) + substs) + result))) + ((head tail ...) + (loop items tail + (cons head result))))))))) (define* (fold-path store proc seed path #:optional (relatives (cut references store <>))) @@ -852,7 +858,9 @@ topological order." (operation (query-substitutable-path-infos (store-path-list paths)) "Return information about the subset of PATHS that is substitutable. For each substitutable path, a `substitutable?' object is -returned." +returned; thus, the resulting list can be shorter than PATHS. Furthermore, +that there is no guarantee that the order of the resulting list matches the +order of PATHS." substitutable-path-list)) (define-operation (optimize-store) -- cgit v1.2.3 From 322bb53c7aca0855833d07a7ea55ae243235f285 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 6 Mar 2016 21:50:40 +0100 Subject: import: snix: Use the right 'package-name->name+version'. Fixes a regression introduced in 1b846da8c372bee78851439fd9e72b2499115e5a. * guix/import/snix.scm: Use 'package-name->name+version' from (guix build utils). --- guix/import/snix.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/snix.scm b/guix/import/snix.scm index 033b7165d3..bc75cbfda5 100644 --- a/guix/import/snix.scm +++ b/guix/import/snix.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -31,7 +31,13 @@ #:use-module (srfi srfi-37) #:use-module (system foreign) #:use-module (rnrs bytevectors) - #:use-module (guix utils) + + ;; Use the 'package-name->name+version' procedure that works with + ;; hyphen-separate name/version, not the one that works with '@'-separated + ;; name/version. Subtle! + #:use-module ((guix utils) #:hide (package-name->name+version)) + #:use-module ((guix build utils) #:select (package-name->name+version)) + #:use-module (guix import utils) #:use-module (guix base32) #:use-module (guix config) -- cgit v1.2.3 From 198d84b70bd26af1994c01fa1429f0e88991e896 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 18 Oct 2014 18:19:08 +0200 Subject: packages: Generalize the 'cached' macro. * guix/packages.scm (cache): Rename to... (cache!): ... this. Add 'cache' parameter, and use it. (cached): Add a rule to allow the cache to be specified. --- guix/packages.scm | 37 ++++++++++++++++++++----------------- 1 file changed, 20 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 1769238b5e..ee62c8442a 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -727,8 +727,8 @@ dependencies are known to build on SYSTEM." ;; Package to derivation-path mapping. (make-weak-key-hash-table 100)) -(define (cache package system thunk) - "Memoize the return values of THUNK as the derivation of PACKAGE on +(define (cache! cache package system thunk) + "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on SYSTEM." ;; FIXME: This memoization should be associated with the open store, because ;; otherwise it breaks when switching to a different store. @@ -736,26 +736,29 @@ SYSTEM." ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the ;; same value for all structs (as of Guile 2.0.6), and because pointer ;; equality is sufficient in practice. - (hashq-set! %derivation-cache package + (hashq-set! cache package `((,system ,@vals) - ,@(or (hashq-ref %derivation-cache package) - '()))) + ,@(or (hashq-ref cache package) '()))) (apply values vals))) -(define-syntax-rule (cached package system body ...) - "Memoize the result of BODY for the arguments PACKAGE and SYSTEM. +(define-syntax cached + (syntax-rules (=>) + "Memoize the result of BODY for the arguments PACKAGE and SYSTEM. Return the cached result when available." - (let ((thunk (lambda () body ...)) - (key system)) - (match (hashq-ref %derivation-cache package) - ((alist (... ...)) - (match (assoc-ref alist key) - ((vals (... ...)) - (apply values vals)) + ((_ (=> cache) package system body ...) + (let ((thunk (lambda () body ...)) + (key system)) + (match (hashq-ref cache package) + ((alist (... ...)) + (match (assoc-ref alist key) + ((vals (... ...)) + (apply values vals)) + (#f + (cache! cache package key thunk)))) (#f - (cache package key thunk)))) - (#f - (cache package key thunk))))) + (cache! cache package key thunk))))) + ((_ package system body ...) + (cached (=> %derivation-cache) package system body ...)))) (define* (expand-input store package input system #:optional cross-system) "Expand INPUT, an input tuple, such that it contains only references to -- cgit v1.2.3 From 9775412ee05d2510970d6ee842f42f3702b3c44c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Mar 2016 23:52:35 +0100 Subject: packages: Cache the result of 'package->bag'. This reduces the wall-clock time of guix environment gnutls --pure -E true by ~25%. * guix/packages.scm (%bag-cache): New variable. (package->bag): Use 'cached' to cache things to %BAG-CACHE. --- guix/packages.scm | 67 +++++++++++++++++++++++++++++++------------------------ 1 file changed, 38 insertions(+), 29 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index ee62c8442a..92222c0def 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -798,41 +798,50 @@ information in exceptions." (package package) (input x))))))) +(define %bag-cache + ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags. + ;; It significantly speeds things up when doing repeated calls to + ;; 'package->bag' as is the case when building a profile. + (make-weak-key-hash-table 200)) + (define* (package->bag package #:optional (system (%current-system)) (target (%current-target-system)) #:key (graft? (%graft?))) "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET, and return it." - ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked field - ;; values can refer to it. - (parameterize ((%current-system system) - (%current-target-system target)) - (match (if graft? - (or (package-replacement package) package) - package) - (($ name version source build-system - args inputs propagated-inputs native-inputs self-native-input? - outputs) - (or (make-bag build-system (string-append name "-" version) - #:system system - #:target target - #:source source - #:inputs (append (inputs) - (propagated-inputs)) - #:outputs outputs - #:native-inputs `(,@(if (and target self-native-input?) - `(("self" ,package)) - '()) - ,@(native-inputs)) - #:arguments (args)) - (raise (if target - (condition - (&package-cross-build-system-error - (package package))) - (condition - (&package-error - (package package)))))))))) + (cached (=> %bag-cache) + package (list system target graft?) + ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked + ;; field values can refer to it. + (parameterize ((%current-system system) + (%current-target-system target)) + (match (if graft? + (or (package-replacement package) package) + package) + (($ name version source build-system + args inputs propagated-inputs native-inputs + self-native-input? outputs) + (or (make-bag build-system (string-append name "-" version) + #:system system + #:target target + #:source source + #:inputs (append (inputs) + (propagated-inputs)) + #:outputs outputs + #:native-inputs `(,@(if (and target + self-native-input?) + `(("self" ,package)) + '()) + ,@(native-inputs)) + #:arguments (args)) + (raise (if target + (condition + (&package-cross-build-system-error + (package package))) + (condition + (&package-error + (package package))))))))))) (define (input-graft store system) "Return a procedure that, given a package with a graft, returns a graft, and -- cgit v1.2.3 From ced71ac7a78f12d39a41f7102019bdb1aec93dee Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Mar 2016 23:57:33 +0100 Subject: packages: Cache the result of 'input-grafts'. This reduces the wall-clock time of guix environment gnutls --pure -E true by ~35%. * guix/packages.scm (%graft-cache): New variable. (input-graft): Use 'cached' to cache to %GRAFT-CACHE. --- guix/packages.scm | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 92222c0def..d62d1f3343 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -843,6 +843,11 @@ and return it." (&package-error (package package))))))))))) +(define %graft-cache + ;; 'eq?' cache mapping package objects to a graft corresponding to their + ;; replacement package. + (make-weak-key-hash-table 200)) + (define (input-graft store system) "Return a procedure that, given a package with a graft, returns a graft, and #f otherwise." @@ -850,12 +855,13 @@ and return it." ((? package? package) (let ((replacement (package-replacement package))) (and replacement - (let ((orig (package-derivation store package system - #:graft? #f)) - (new (package-derivation store replacement system))) - (graft - (origin orig) - (replacement new)))))) + (cached (=> %graft-cache) package system + (let ((orig (package-derivation store package system + #:graft? #f)) + (new (package-derivation store replacement system))) + (graft + (origin orig) + (replacement new))))))) (x #f))) -- cgit v1.2.3 From 16210486e6bb2e7b81e0208e42584b1eed826cd0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 8 Mar 2016 11:03:02 +0100 Subject: guix system: Write the GC root on the target file system. Fixes . Reported by Jookia <166291@gmail.com>. * guix/scripts/system.scm (install-grub*): Prepend TARGET to GC-ROOT. --- guix/scripts/system.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 9f56a96ca0..8ebeb4d595 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -128,7 +128,8 @@ TARGET, and register them." (define (install-grub* grub.cfg device target) "This is a variant of 'install-grub' with error handling, lifted in %STORE-MONAD" - (let* ((gc-root (string-append %gc-roots-directory "/grub.cfg")) + (let* ((gc-root (string-append target %gc-roots-directory + "/grub.cfg")) (temp-gc-root (string-append gc-root ".new")) (delete-file (lift1 delete-file %store-monad)) (make-symlink (lift2 switch-symlinks %store-monad)) -- cgit v1.2.3 From 5284339d9d31c97146d92ee3f860ba5c70b77c46 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 8 Mar 2016 22:00:17 +0100 Subject: guix build: Add '--quiet'. Fixes . Reported by Andrei Osipov . * guix/scripts/build.scm (show-help, %options): Add --quiet. (guix-build): Parameterize 'current-build-output-port' accordingly. * doc/guix.texi (Invoking guix build): Use it in example. (Additional Build Options): Document it. --- doc/guix.texi | 8 +++- guix/scripts/build.scm | 100 +++++++++++++++++++++++++++---------------------- 2 files changed, 63 insertions(+), 45 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 0e8e5ad3a9..7945415d7a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3836,7 +3836,7 @@ guix build emacs guile Similarly, the following command builds all the available packages: @example -guix build --keep-going \ +guix build --quiet --keep-going \ `guix package -A | cut -f1,2 --output-delimiter=@@` @end example @@ -4070,6 +4070,12 @@ build}. @table @code +@item --quiet +@itemx -q +Build quietly, without displaying the build log. Upon completion, the +build log is kept in @file{/var} (or similar) and can always be +retrieved using the @option{--log-file} option. + @item --file=@var{file} @itemx -f @var{file} diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 3607d78537..b25bf50d2b 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -466,6 +466,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (display (_ " -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) + (display (_ " + -q, --quiet do not show the build log")) (display (_ " --log-file return the log file names for the given derivations")) (newline) @@ -534,6 +536,9 @@ must be one of 'package', 'all', or 'transitive'~%") (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) + (option '(#\q "quiet") #f #f + (lambda (opt name arg result) + (alist-cons 'quiet? #t result))) (option '("log-file") #f #f (lambda (opt name arg result) (alist-cons 'log-file? #t result))) @@ -638,6 +643,9 @@ needed." (parse-command-line args %options (list %default-options))) + (define quiet? + (assoc-ref opts 'quiet?)) + (with-error-handling ;; Ask for absolute file names so that .drv file names passed from the ;; user to 'read-derivation' are absolute when it returns. @@ -646,47 +654,51 @@ needed." ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) - (let* ((mode (assoc-ref opts 'build-mode)) - (drv (options->derivations store opts)) - (urls (map (cut string-append <> "/log") - (if (assoc-ref opts 'substitutes?) - (or (assoc-ref opts 'substitute-urls) - ;; XXX: This does not necessarily match the - ;; daemon's substitute URLs. - %default-substitute-urls) - '()))) - (items (filter-map (match-lambda - (('argument . (? store-path? file)) - file) - (_ #f)) - opts)) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) - opts))) - - (unless (assoc-ref opts 'log-file?) - (show-what-to-build store drv - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?) - #:mode mode)) - - (cond ((assoc-ref opts 'log-file?) - (for-each (cut show-build-log store <> urls) - (delete-duplicates - (append (map derivation-file-name drv) - items)))) - ((assoc-ref opts 'derivations-only?) - (format #t "~{~a~%~}" (map derivation-file-name drv)) - (for-each (cut register-root store <> <>) - (map (compose list derivation-file-name) drv) - roots)) - ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations store drv mode) - (for-each show-derivation-outputs drv) - (for-each (cut register-root store <> <>) - (map (lambda (drv) - (map cdr - (derivation->output-paths drv))) - drv) - roots))))))))) + (parameterize ((current-build-output-port (if quiet? + (%make-void-port "w") + (current-error-port)))) + (let* ((mode (assoc-ref opts 'build-mode)) + (drv (options->derivations store opts)) + (urls (map (cut string-append <> "/log") + (if (assoc-ref opts 'substitutes?) + (or (assoc-ref opts 'substitute-urls) + ;; XXX: This does not necessarily match the + ;; daemon's substitute URLs. + %default-substitute-urls) + '()))) + (items (filter-map (match-lambda + (('argument . (? store-path? file)) + file) + (_ #f)) + opts)) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) + + (unless (assoc-ref opts 'log-file?) + (show-what-to-build store drv + #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?) + #:mode mode)) + + (cond ((assoc-ref opts 'log-file?) + (for-each (cut show-build-log store <> urls) + (delete-duplicates + (append (map derivation-file-name drv) + items)))) + ((assoc-ref opts 'derivations-only?) + (format #t "~{~a~%~}" (map derivation-file-name drv)) + (for-each (cut register-root store <> <>) + (map (compose list derivation-file-name) drv) + roots)) + ((not (assoc-ref opts 'dry-run?)) + (and (build-derivations store drv mode) + (for-each show-derivation-outputs drv) + (for-each (cut register-root store <> <>) + (map (lambda (drv) + (map cdr + (derivation->output-paths drv))) + drv) + roots)))))))))) -- cgit v1.2.3 From f1eacbafc4b98b8665856640c9d728372857eebf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 9 Mar 2016 15:08:00 +0100 Subject: upstream: Fix 'signature-urls' coalescing. Previously, the resulting 'signature-urls' would contain N times the same URL. * guix/upstream.scm (coalesce-sources): Fix TWO in 'signature-urls'. * tests/upstream.scm: New file. * Makefile.am (SCM_TESTS): Add it. --- Makefile.am | 1 + guix/upstream.scm | 4 ++-- tests/upstream.scm | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 52 insertions(+), 2 deletions(-) create mode 100644 tests/upstream.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 6f8e57c9cc..f67de43f48 100644 --- a/Makefile.am +++ b/Makefile.am @@ -225,6 +225,7 @@ SCM_TESTS = \ tests/grafts.scm \ tests/ui.scm \ tests/records.scm \ + tests/upstream.scm \ tests/utils.scm \ tests/build-utils.scm \ tests/packages.scm \ diff --git a/guix/upstream.scm b/guix/upstream.scm index c62667dd01..cea23feb82 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2015 Alex Kost ;;; ;;; This file is part of GNU Guix. @@ -99,7 +99,7 @@ correspond to the same version." (upstream-source-urls head))) (signature-urls (let ((one (upstream-source-signature-urls release)) - (two (upstream-source-signature-urls release))) + (two (upstream-source-signature-urls head))) (and one two (append one two))))) tail) (cons release result))) diff --git a/tests/upstream.scm b/tests/upstream.scm new file mode 100644 index 0000000000..eb18dd6193 --- /dev/null +++ b/tests/upstream.scm @@ -0,0 +1,49 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 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 (test-upstream) + #:use-module (guix upstream) + #:use-module (guix tests) + #:use-module (srfi srfi-64)) + + +(test-begin "upstream") + +(test-equal "coalesce-sources same version" + (list (upstream-source + (package "foo") (version "1") + (urls '("ftp://example.org/foo-1.tar.xz" + "ftp://example.org/foo-1.tar.gz")) + (signature-urls '("ftp://example.org/foo-1.tar.xz.sig" + "ftp://example.org/foo-1.tar.gz.sig")))) + + (coalesce-sources (list (upstream-source + (package "foo") (version "1") + (urls '("ftp://example.org/foo-1.tar.gz")) + (signature-urls + '("ftp://example.org/foo-1.tar.gz.sig"))) + (upstream-source + (package "foo") (version "1") + (urls '("ftp://example.org/foo-1.tar.xz")) + (signature-urls + '("ftp://example.org/foo-1.tar.xz.sig")))))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) -- cgit v1.2.3 From bec7f352145699c929425397957c52a3829623cf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 9 Mar 2016 23:37:12 +0100 Subject: ui: Do not call 'port-filename' on closed file ports. * guix/ui.scm (call-with-error-handling)[port-filename*]: New procedure. Use it in the 'nar-error?' case. --- guix/ui.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index a3ec6834b6..7b7bee0ac8 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -410,6 +410,12 @@ interpreted." (define (call-with-error-handling thunk) "Call THUNK within a user-friendly error handler." + (define (port-filename* port) + ;; 'port-filename' returns #f for non-file ports, but it raises an + ;; exception for file ports that are closed. Work around that. + (and (not (port-closed? port)) + (port-filename port))) + (guard (c ((package-input-error? c) (let* ((package (package-error-package c)) (input (package-error-invalid-input c)) @@ -440,9 +446,9 @@ interpreted." (port (nar-error-port c))) (if file (leave (_ "corrupt input while restoring '~a' from ~s~%") - file (or (port-filename port) port)) + file (or (port-filename* port) port)) (leave (_ "corrupt input while restoring archive from ~s~%") - (or (port-filename port) port))))) + (or (port-filename* port) port))))) ((nix-connection-error? c) (leave (_ "failed to connect to `~a': ~a~%") (nix-connection-error-file c) -- cgit v1.2.3 From 204d34ff961d6dabf18b255decc29712e03afef0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 9 Mar 2016 18:34:04 +0100 Subject: substitute: Error out on unsupported URL schemes. Reported in by Chris Marusich . * guix/scripts/substitute.scm (fetch): Add 'else' case and call 'leave'. --- guix/scripts/substitute.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 01cc3f129e..0a716a95fd 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2014 Nikita Karetnikov ;;; ;;; This file is part of GNU Guix. @@ -204,7 +204,10 @@ to the caller without emitting an error message." (set! port (open-socket-for-uri uri)) (unless buffered? (setvbuf port _IONBF))) - (http-fetch uri #:text? #f #:port port)))))))) + (http-fetch uri #:text? #f #:port port)))))) + (else + (leave (_ "unsupported substitute URI scheme: ~a~%") + (uri->string uri))))) (define-record-type (%make-cache-info url store-directory wants-mass-query?) -- cgit v1.2.3 From 9b7bd1b160be7c740a798c09e3b8986368b92036 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 10 Mar 2016 11:53:03 +0100 Subject: substitute: Add HTTPS support. Fixes . Reported by Chris Marusich . * guix/scripts/substitute.scm (fetch): Add 'https' alongside 'http'. Use 'open-connection-for-uri' instead of 'open-socket-for-uri'. Call 'setvbuf' only when PORT matches 'file-port?'. (http-multiple-get): Likewise. Change 'base-url' parameter to 'base-uri'. (fetch-narinfos)[do-fetch]: Add 'https' case alongside 'http'. Pass URI instead of URL to 'http-multiple-get'. * doc/guix.texi (Requirements): Move GnuTLS one level higher and mention HTTPS substitutes. (Substitutes): Mention HTTPS and recommend it. Explain why servers are not authenticated. Add "On Trusting Binaries" subsection. --- doc/guix.texi | 35 +++++++++++++++++++++++++++-------- guix/scripts/substitute.scm | 23 ++++++++++++++--------- 2 files changed, 41 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 06b40fac59..dbb2ae8ad3 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -484,19 +484,21 @@ GNU Guix depends on the following packages: The following dependencies are optional: @itemize +@item +Installing @uref{http://gnutls.org/, GnuTLS-Guile} will allow you to +access @code{https} URLs for substitutes, which is highly recommended +(@pxref{Substitutes}). It also allows you to access HTTPS URLs with the +@command{guix download} command (@pxref{Invoking guix download}), the +@command{guix import pypi} command, and the @command{guix import cpan} +command. @xref{Guile Preparations, how to install the GnuTLS bindings +for Guile,, gnutls-guile, GnuTLS-Guile}. + @item Installing @url{http://savannah.nongnu.org/projects/guile-json/, Guile-JSON} will allow you to use the @command{guix import pypi} command (@pxref{Invoking guix import}). It is of interest primarily for developers and not for casual users. -@item -Installing @uref{http://gnutls.org/, GnuTLS-Guile} will -allow you to access @code{https} URLs with the @command{guix download} -command (@pxref{Invoking guix download}), the @command{guix import pypi} -command, and the @command{guix import cpan} command. This is primarily -of interest to developers. @xref{Guile Preparations, how to install the -GnuTLS bindings for Guile,, gnutls-guile, GnuTLS-Guile}. @end itemize Unless @code{--disable-daemon} was passed to @command{configure}, the @@ -1703,6 +1705,13 @@ or to client tools such as @command{guix package} (@pxref{client-substitute-urls,, client @option{--substitute-urls} option}). +Substitute URLs can be either HTTP or HTTPS@footnote{For HTTPS access, +the Guile bindings of GnuTLS must be installed. @xref{Requirements}.} +HTTPS is recommended because communications are encrypted; conversely, +using HTTP makes all communications visible to an eavesdropper, who +could use the information gathered to determine, for instance, whether +your system has unpatched security vulnerabilities. + @cindex security @cindex digital signatures To allow Guix to download substitutes from @code{hydra.gnu.org}, you @@ -1757,13 +1766,21 @@ one of the keys listed in the ACL. It also detects and raises an error when attempting to use a substitute that has been tampered with. @vindex http_proxy -Substitutes are downloaded over HTTP. The @code{http_proxy} environment +Substitutes are downloaded over HTTP or HTTPS. +The @code{http_proxy} environment variable can be set in the environment of @command{guix-daemon} and is honored for downloads of substitutes. Note that the value of @code{http_proxy} in the environment where @command{guix build}, @command{guix package}, and other client commands are run has @emph{absolutely no effect}. +When using HTTPS, the server's X.509 certificate is @emph{not} validated +(in other words, the server is not authenticated), contrary to what +HTTPS clients such as Web browsers usually do. This is because Guix +authenticates substitute information itself, as explained above, which +is what we care about (whereas X.509 certificates are about +authenticating bindings between domain names and public keys.) + The substitute mechanism can be disabled globally by running @code{guix-daemon} with @code{--no-substitutes} (@pxref{Invoking guix-daemon}). It can also be disabled temporarily by passing the @@ -1771,6 +1788,8 @@ guix-daemon}). It can also be disabled temporarily by passing the build}, and other command-line tools. +@unnumberedsubsec On Trusting Binaries + Today, each individual's control over their own computing is at the mercy of institutions, corporations, and groups with enough power and determination to subvert the computing infrastructure and exploit its diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 0a716a95fd..cc637c8d13 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -32,6 +32,7 @@ #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) #:select (progress-proc uri-abbreviation + open-connection-for-uri store-path-abbreviation byte-count->string)) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) @@ -49,6 +50,7 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (web uri) + #:use-module (web http) #:use-module (web request) #:use-module (web response) #:use-module (guix http-client) @@ -171,7 +173,7 @@ to the caller without emitting an error message." (let ((port (open-file (uri-path uri) (if buffered? "rb" "r0b")))) (values port (stat:size (stat port))))) - ((http) + ((http https) (guard (c ((http-get-error? c) (let ((code (http-get-error-code c))) (if (and (= code 404) quiet-404?) @@ -201,8 +203,8 @@ to the caller without emitting an error message." (close-port port)))) (begin (when (or (not port) (port-closed? port)) - (set! port (open-socket-for-uri uri)) - (unless buffered? + (set! port (open-connection-for-uri uri)) + (unless (or buffered? (not (file-port? port))) (setvbuf port _IONBF))) (http-fetch uri #:text? #f #:port port)))))) (else @@ -478,8 +480,8 @@ may be #f, in which case it indicates that PATH is unavailable at CACHE-URL." ".narinfo"))) (build-request (string->uri url) #:method 'GET))) -(define (http-multiple-get base-url proc seed requests) - "Send all of REQUESTS to the server at BASE-URL. Call PROC for each +(define (http-multiple-get base-uri proc seed requests) + "Send all of REQUESTS to the server at BASE-URI. Call PROC for each response, passing it the request object, the response, a port from which to read the response body, and the previous result, starting with SEED, à la 'fold'. Return the final result." @@ -487,9 +489,12 @@ read the response body, and the previous result, starting with SEED, à la (result seed)) ;; (format (current-error-port) "connecting (~a requests left)..." ;; (length requests)) - (let ((p (open-socket-for-uri base-url))) + (let ((p (open-connection-for-uri base-uri))) + ;; For HTTPS, P is not a file port and does not support 'setvbuf'. + (when (file-port? p) + (setvbuf p _IOFBF (expt 2 16))) + ;; Send all of REQUESTS in a row. - (setvbuf p _IOFBF (expt 2 16)) (for-each (cut write-request <> p) requests) (force-output p) @@ -570,10 +575,10 @@ if file doesn't exist, and the narinfo otherwise." (define (do-fetch uri) (case (and=> uri uri-scheme) - ((http) + ((http https) (let ((requests (map (cut narinfo-request url <>) paths))) (update-progress!) - (let ((result (http-multiple-get url + (let ((result (http-multiple-get uri handle-narinfo-response '() requests))) (newline (current-error-port)) -- cgit v1.2.3 From ec278439f3ff5dcd3d02c05099ba1724cc2459f1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 10 Mar 2016 13:53:23 +0100 Subject: substitute: Optimize HTTP pipelining over TLS. * guix/scripts/substitute.scm (http-multiple-get): Write the requests to a bytevector output port before sending them. --- guix/scripts/substitute.scm | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index cc637c8d13..b057e9b12a 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -495,8 +495,17 @@ read the response body, and the previous result, starting with SEED, à la (setvbuf p _IOFBF (expt 2 16))) ;; Send all of REQUESTS in a row. - (for-each (cut write-request <> p) requests) - (force-output p) + ;; XXX: Do our own caching to work around inefficiencies when + ;; communicating over TLS: . + (let-values (((buffer get) (open-bytevector-output-port))) + ;; On Guile > 2.0.9, inherit the HTTP proxying property from P. + (when (module-variable (resolve-interface '(web http)) + 'http-proxy-port?) + (set-http-proxy-port?! buffer (http-proxy-port? p))) + + (for-each (cut write-request <> buffer) requests) + (put-bytevector p (get)) + (force-output p)) ;; Now start processing responses. (let loop ((requests requests) -- cgit v1.2.3 From cf557afa2e679f73b93796460dee23d5c5c314c5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 11 Mar 2016 10:21:58 +0100 Subject: cve: Make CPE patch level part of the version string. * guix/cve.scm (%cpe-package-rx): Adjust to account for :PATCH-LEVEL. (cpe->package-name): Likewise. --- guix/cve.scm | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/cve.scm b/guix/cve.scm index a7b0bde6dc..663097b483 100644 --- a/guix/cve.scm +++ b/guix/cve.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès +;;; Copyright © 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -70,8 +70,9 @@ (close-port port))))) (define %cpe-package-rx - ;; For applications: "cpe:/a:VENDOR:PACKAGE:VERSION". - (make-regexp "^cpe:/a:([^:]+):([^:]+):([^:]+)")) + ;; For applications: "cpe:/a:VENDOR:PACKAGE:VERSION", or sometimes + ;; "cpe/a:VENDOR:PACKAGE:VERSION:PATCH-LEVEL". + (make-regexp "^cpe:/a:([^:]+):([^:]+):([^:]+)((:.+)?)")) (define (cpe->package-name cpe) "Converts the Common Platform Enumeration (CPE) string CPE to a package @@ -80,7 +81,13 @@ CPE string." (and=> (regexp-exec %cpe-package-rx (string-trim-both cpe)) (lambda (matches) (cons (match:substring matches 2) - (match:substring matches 3))))) + (string-append (match:substring matches 3) + (match (match:substring matches 4) + ("" "") + (patch-level + ;; Drop the colon from things like + ;; "cpe:/a:openbsd:openssh:6.8:p1". + (string-drop patch-level 1)))))))) (define %parse-vulnerability-feed ;; Parse the XML vulnerability feed from -- cgit v1.2.3 From 6a25e59514f590aa541ec35ba36fd36b2a1dcbc3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 11 Mar 2016 15:55:57 +0100 Subject: cve: Read entire CVE databases for the current year and the past year. The "Modified" database that we were reading is much smaller, but it only shows CVEs modified over the past week. * guix/cve.scm (%now, %current-year, %past-year): New variables. (yearly-feed-uri): New procedure. (%cve-feed-uri, %ttl): Remove. (%current-year-ttl, %past-year-ttl): New variables. (call-with-cve-port): Add 'uri' and 'ttl' parameters and honor them. Add 'setvbuf' call. (current-vulnerabilities)[read-vulnerabilities]: New procedure. Read from both %LAST-YEAR and %CURRENT-YEAR. --- guix/cve.scm | 51 +++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 39 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/cve.scm b/guix/cve.scm index 663097b483..8e76f42f0d 100644 --- a/guix/cve.scm +++ b/guix/cve.scm @@ -49,23 +49,38 @@ (id vulnerability-id) (packages vulnerability-packages)) -(define %cve-feed-uri +(define %now + (current-date)) +(define %current-year + (date-year %now)) +(define %past-year + (- %current-year 1)) + +(define (yearly-feed-uri year) + "Return the URI for the CVE feed for YEAR." (string->uri - "https://nvd.nist.gov/feeds/xml/cve/nvdcve-2.0-Modified.xml.gz")) + (string-append "https://static.nvd.nist.gov/feeds/xml/cve/nvdcve-2.0-" + (number->string year) ".xml.gz"))) -(define %ttl +(define %current-year-ttl ;; According to , feeds are ;; updated "approximately every two hours." (* 3600 3)) -(define (call-with-cve-port proc) +(define %past-year-ttl + ;; Update the previous year's database more and more infrequently. + (* 3600 24 2 (date-month %now))) + +(define (call-with-cve-port uri ttl proc) "Pass PROC an input port from which to read the CVE stream." - (let ((port (http-fetch/cached %cve-feed-uri #:ttl %ttl))) + (let ((port (http-fetch/cached uri #:ttl ttl))) (dynamic-wind (const #t) (lambda () (call-with-decompressed-port 'gzip port - proc)) + (lambda (port) + (setvbuf port _IOFBF 65536) + (proc port)))) (lambda () (close-port port))))) @@ -142,12 +157,19 @@ vulnerability objects." (define (current-vulnerabilities) "Return the current list of Common Vulnerabilities and Exposures (CVE) as published by the US NIST." - (call-with-cve-port - (lambda (port) - ;; XXX: The SSAX "error port" is used to send pointless warnings such as - ;; "warning: Skipping PI". Turn that off. - (parameterize ((current-ssax-error-port (%make-void-port "w"))) - (xml->vulnerabilities port))))) + (define (read-vulnerabilities uri ttl) + (call-with-cve-port uri ttl + (lambda (port) + ;; XXX: The SSAX "error port" is used to send pointless warnings such as + ;; "warning: Skipping PI". Turn that off. + (parameterize ((current-ssax-error-port (%make-void-port "w"))) + (xml->vulnerabilities port))))) + + (append-map read-vulnerabilities + (list (yearly-feed-uri %past-year) + (yearly-feed-uri %current-year)) + (list %past-year-ttl + %current-year-ttl))) (define (vulnerabilities->lookup-proc vulnerabilities) "Return a lookup procedure built from VULNERABILITIES that takes a package @@ -181,4 +203,9 @@ a list of vulnerabilities affection the given package version." '() package table))) + +;;; Local Variables: +;;; eval: (put 'call-with-cve-port 'scheme-indent-function 2) +;;; End: + ;;; cve.scm ends here -- cgit v1.2.3 From 5f7a1a4def8494940a4a2bc3728fb9cd927a14f8 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 29 Dec 2015 16:56:49 +0100 Subject: build: Add Ant build system. * guix/build-system/ant.scm: New file. * guix/build/ant-build-system: New file. * Makefile.am (MODULES): Add new files. * doc/guix.texi (Build Systems): Document ant-build-system. --- Makefile.am | 2 + doc/guix.texi | 21 ++++++ guix/build-system/ant.scm | 149 +++++++++++++++++++++++++++++++++++++ guix/build/ant-build-system.scm | 160 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 332 insertions(+) create mode 100644 guix/build-system/ant.scm create mode 100644 guix/build/ant-build-system.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index f67de43f48..92a3bc5f82 100644 --- a/Makefile.am +++ b/Makefile.am @@ -56,6 +56,7 @@ MODULES = \ guix/graph.scm \ guix/cve.scm \ guix/build-system.scm \ + guix/build-system/ant.scm \ guix/build-system/cmake.scm \ guix/build-system/emacs.scm \ guix/build-system/glib-or-gtk.scm \ @@ -75,6 +76,7 @@ MODULES = \ guix/cvs-download.scm \ guix/svn-download.scm \ guix/ui.scm \ + guix/build/ant-build-system.scm \ guix/build/download.scm \ guix/build/cmake-build-system.scm \ guix/build/emacs-build-system.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index f7deafa516..7509ea9dc2 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2720,6 +2720,27 @@ of @var{gnu-build-system}, and differ mainly in the set of inputs implicitly added to the build process, and in the list of phases executed. Some of these build systems are listed below. +@defvr {Scheme Variable} ant-build-system +This variable is exported by @code{(guix build-system ant)}. It +implements the build procedure for Java packages that can be built with +@url{http://ant.apache.org/, Ant build tool}. + +It adds both @code{ant} and the @dfn{Java Development Kit} (JDK) as +provided by the @code{icedtea} package to the set of inputs. Different +packages can be specified with the @code{#:ant} and @code{#:jdk} +parameters, respectively. + +When the original package does not provide a suitable Ant build file, +the parameter @code{#:jar-name} can be used to generate a minimal Ant +build file @file{build.xml} with tasks to build the specified jar +archive. + +The parameter @code{#:build-target} can be used to specify the Ant task +that should be run during the @code{build} phase. By default the +``jar'' task will be run. + +@end defvr + @defvr {Scheme Variable} cmake-build-system This variable is exported by @code{(guix build-system cmake)}. It implements the build procedure for packages using the diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm new file mode 100644 index 0000000000..d3054e5ffa --- /dev/null +++ b/guix/build-system/ant.scm @@ -0,0 +1,149 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ricardo Wurmus +;;; +;;; 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 build-system ant) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:export (%ant-build-system-modules + ant-build + ant-build-system)) + +;; Commentary: +;; +;; Standard build procedure for Java packages using Ant. +;; +;; Code: + +(define %ant-build-system-modules + ;; Build-side modules imported by default. + `((guix build ant-build-system) + (guix build syscalls) + ,@%gnu-build-system-modules)) + +(define (default-jdk) + "Return the default JDK package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((jdk-mod (resolve-interface '(gnu packages java)))) + (module-ref jdk-mod 'icedtea))) + +(define (default-ant) + "Return the default Ant package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((jdk-mod (resolve-interface '(gnu packages java)))) + (module-ref jdk-mod 'ant))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (jdk (default-jdk)) + (ant (default-ant)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:jdk #:ant #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("jdk" ,jdk "jdk") + ("ant" ,ant) + ,@native-inputs)) + (outputs outputs) + (build ant-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (ant-build store name inputs + #:key + (tests? #t) + (test-target "tests") + (configure-flags ''()) + (make-flags ''()) + (build-target "jar") + (jar-name #f) + (phases '(@ (guix build ant-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f)p + (imported-modules %ant-build-system-modules) + (modules '((guix build ant-build-system) + (guix build utils)))) + "Build SOURCE with INPUTS." + (define builder + `(begin + (use-modules ,@modules) + (ant-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:make-flags ,make-flags + #:configure-flags ,configure-flags + #:system ,system + #:tests? ,tests? + #:test-target ,test-target + #:build-target ,build-target + #:jar-name ,jar-name + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define ant-build-system + (build-system + (name 'ant) + (description "The standard Ant build system") + (lower lower))) + +;;; ant.scm ends here diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm new file mode 100644 index 0000000000..d302b948b5 --- /dev/null +++ b/guix/build/ant-build-system.scm @@ -0,0 +1,160 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ricardo Wurmus +;;; +;;; 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 build ant-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build syscalls) + #:use-module (guix build utils) + #:use-module (sxml simple) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + ant-build)) + +;; Commentary: +;; +;; Builder-side code of the standard build procedure for Java packages using +;; Ant. +;; +;; Code: + +(define (default-build.xml jar-name prefix) + "Create a simple build.xml with standard targets for Ant." + (call-with-output-file "build.xml" + (lambda (port) + (sxml->xml + `(project (@ (basedir ".")) + (property (@ (name "classes.dir") + (value "${basedir}/build/classes"))) + (property (@ (name "jar.dir") + (value "${basedir}/build/jar"))) + (property (@ (name "dist.dir") + (value ,prefix))) + + ;; respect the CLASSPATH environment variable + (property (@ (name "build.sysclasspath") + (value "first"))) + (property (@ (environment "env"))) + (path (@ (id "classpath")) + (pathelement (@ (location "${env.CLASSPATH}")))) + + (target (@ (name "compile")) + (mkdir (@ (dir "${classes.dir}"))) + (javac (@ (includeantruntime "false") + (srcdir "src") + (destdir "${classes.dir}") + (classpath (@ (refid "classpath")))))) + + (target (@ (name "jar") + (depends "compile")) + (mkdir (@ (dir "${jar.dir}"))) + ;; We cannot use the simpler "jar" task here, because + ;; there is no way to disable generation of a + ;; manifest. We do not include a generated manifest + ;; to ensure determinism, because we cannot easily + ;; reset the ctime/mtime before creating the archive. + (exec (@ (executable "jar")) + (arg (@ (line ,(string-append "-Mcf ${jar.dir}/" jar-name + " -C ${classes.dir} .")))))) + + (target (@ (name "install")) + (copy (@ (todir "${dist.dir}")) + (fileset (@ (dir "${jar.dir}")) + (include (@ (name "**/*.jar"))))))) + port))) + (utime "build.xml" 0 0) + #t) + +(define (generate-classpath inputs) + "Return a colon-separated string of full paths to jar files found among the +INPUTS." + (string-join + (apply append (map (match-lambda + ((_ . dir) + (find-files dir "\\.*jar$"))) + inputs)) ":")) + +(define* (configure #:key inputs outputs (jar-name #f) + #:allow-other-keys) + (when jar-name + (default-build.xml jar-name + (string-append (assoc-ref outputs "out") + "/share/java"))) + (setenv "JAVA_HOME" (assoc-ref inputs "jdk")) + (setenv "CLASSPATH" (generate-classpath inputs))) + +(define* (build #:key (make-flags '()) (build-target "jar") + #:allow-other-keys) + (zero? (apply system* `("ant" ,build-target ,@make-flags)))) + +(define* (strip-jar-timestamps #:key outputs + #:allow-other-keys) + "Unpack all jar archives, reset the timestamp of all contained files, and +repack them. This is necessary to ensure that archives are reproducible." + (define (repack-archive jar) + (format #t "repacking ~a\n" jar) + (let ((dir (mkdtemp! "jar-contents.XXXXXX"))) + (and (with-directory-excursion dir + (zero? (system* "jar" "xf" jar))) + ;; The manifest file contains timestamps + (for-each delete-file (find-files dir "MANIFEST.MF")) + (delete-file jar) + ;; XXX: copied from (gnu build install) + (for-each (lambda (file) + (let ((s (lstat file))) + (unless (eq? (stat:type s) 'symlink) + (utime file 0 0 0 0)))) + (find-files dir #:directories? #t)) + (unless (zero? (system* "jar" "-Mcf" jar "-C" dir ".")) + (error "'jar' failed")) + (utime jar 0 0) + #t))) + + (every (match-lambda + ((output . directory) + (every repack-archive (find-files directory "\\.jar$")))) + outputs)) + +(define* (check #:key target (make-flags '()) (tests? (not target)) + (test-target "check") + #:allow-other-keys) + (if tests? + (zero? (apply system* `("ant" ,test-target ,@make-flags))) + (begin + (format #t "test suite not run~%") + #t))) + +(define* (install #:key (make-flags '()) #:allow-other-keys) + (zero? (apply system* `("ant" "install" ,@make-flags)))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (replace 'configure configure) + (replace 'build build) + (replace 'check check) + (replace 'install install) + (add-after 'install 'strip-jar-timestamps strip-jar-timestamps))) + +(define* (ant-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Java package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) + +;;; ant-build-system.scm ends here -- cgit v1.2.3 From 3667bb6cb0f6d42ab1bb2434c1f3c1a93c6f4800 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Mar 2016 09:54:30 +0100 Subject: size: Disable grafts. * guix/scripts/size.scm (guix-size): Parametrize '%graft?'. --- guix/scripts/size.scm | 33 +++++++++++++++++++-------------- 1 file changed, 19 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index e999cce1fd..8f0cb7decd 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ludovic Courtès +;;; Copyright © 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +22,7 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (guix utils) + #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (gnu packages) @@ -274,19 +275,23 @@ Report the size of PACKAGE and its dependencies.\n")) (leave (_ "missing store item argument\n"))) ((file) (leave-on-EPIPE - (with-store store - (set-build-options store - #:use-substitutes? #t - #:substitute-urls urls) + ;; Turn off grafts because (1) hydra.gnu.org does not serve grafted + ;; packages, and (2) they do not make any difference on the + ;; resulting size. + (parameterize ((%graft? #f)) + (with-store store + (set-build-options store + #:use-substitutes? #t + #:substitute-urls urls) - (run-with-store store - (mlet* %store-monad ((item (ensure-store-item file)) - (profile (store-profile item))) - (if map-file - (begin - (profile->page-map profile map-file) - (return #t)) - (display-profile* profile))) - #:system system)))) + (run-with-store store + (mlet* %store-monad ((item (ensure-store-item file)) + (profile (store-profile item))) + (if map-file + (begin + (profile->page-map profile map-file) + (return #t)) + (display-profile* profile))) + #:system system))))) ((files ...) (leave (_ "too many arguments\n"))))))) -- cgit v1.2.3 From f09aea1b58b3ef961d3cc712f116fe4617bc8f90 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Mar 2016 16:53:38 +0100 Subject: store: 'references/substitutes' caches its results. * guix/store.scm (%reference-cache): New variable. (references/substitutes): Use it. --- guix/store.scm | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index a220b6e6f9..01248738dc 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -726,14 +726,23 @@ error if there is no such root." "Return the list of references of PATH." store-path-list)) +(define %reference-cache + ;; Brute-force cache mapping store items to their list of references. + ;; Caching matters because when building a profile in the presence of + ;; grafts, we keep calling 'graft-derivation', which in turn calls + ;; 'references/substitutes' many times with the same arguments. Ideally we + ;; would use a cache associated with the daemon connection instead (XXX). + (make-hash-table 100)) + (define (references/substitutes store items) "Return the list of list of references of ITEMS; the result has the same length as ITEMS. Query substitute information for any item missing from the store at once. Raise a '&nix-protocol-error' exception if reference information for one of ITEMS is missing." (let* ((local-refs (map (lambda (item) - (guard (c ((nix-protocol-error? c) #f)) - (references store item))) + (or (hash-ref %reference-cache item) + (guard (c ((nix-protocol-error? c) #f)) + (references store item)))) items)) (missing (fold-right (lambda (item local-ref result) (if local-ref @@ -757,7 +766,10 @@ the list of references") (result '())) (match items (() - (reverse result)) + (let ((result (reverse result))) + (for-each (cut hash-set! %reference-cache <> <>) + items result) + result)) ((item items ...) (match local-refs ((#f tail ...) -- cgit v1.2.3 From cc27dbcf4af86bb073f1184e6186b2db96a479aa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Mar 2016 17:09:46 +0100 Subject: substitute: Remove dead code. This parameter became unused with the switch to HTTP pipelining in commit d3a652037ef879f9279bc056c43d15ba7afcbb25. * guix/scripts/substitute.scm (fetch): Remove #:quiet-404? and adjust accordingly. --- guix/scripts/substitute.scm | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index b057e9b12a..d20c82a770 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -164,10 +164,9 @@ again." (sigaction SIGALRM SIG_DFL) (apply values result))))) -(define* (fetch uri #:key (buffered? #t) (timeout? #t) (quiet-404? #f)) +(define* (fetch uri #:key (buffered? #t) (timeout? #t)) "Return a binary input port to URI and the number of bytes it's expected to -provide. If QUIET-404? is true, HTTP 404 error conditions are passed through -to the caller without emitting an error message." +provide." (case (uri-scheme uri) ((file) (let ((port (open-file (uri-path uri) @@ -175,12 +174,10 @@ to the caller without emitting an error message." (values port (stat:size (stat port))))) ((http https) (guard (c ((http-get-error? c) - (let ((code (http-get-error-code c))) - (if (and (= code 404) quiet-404?) - (raise c) - (leave (_ "download from '~a' failed: ~a, ~s~%") - (uri->string (http-get-error-uri c)) - code (http-get-error-reason c)))))) + (leave (_ "download from '~a' failed: ~a, ~s~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)))) ;; Test this with: ;; sudo tc qdisc add dev eth0 root netem delay 1500ms ;; and then cancel with: -- cgit v1.2.3 From d262a0f36baa5276076fcd160da7cf7661876eca Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Mar 2016 17:35:09 +0100 Subject: http-client: Add #:keep-alive? parameter. * guix/http-client.scm (http-fetch): Add #:keep-alive? parameter and pass it to 'http-get' or 'http-get*'. --- guix/http-client.scm | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/http-client.scm b/guix/http-client.scm index 2161856c63..25693824ed 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -222,11 +222,14 @@ or if EOF is reached." (module-define! (resolve-module '(web client)) 'shutdown (const #f)) -(define* (http-fetch uri #:key port (text? #f) (buffered? #t)) +(define* (http-fetch uri #:key port (text? #f) (buffered? #t) + keep-alive?) "Return an input port containing the data at URI, and the expected number of bytes available or #f. If TEXT? is true, the data at URI is considered to be textual. Follow any HTTP redirection. When BUFFERED? is #f, return an -unbuffered port, suitable for use in `filtered-port'. +unbuffered port, suitable for use in `filtered-port'. When KEEP-ALIVE? is +true, send a 'Connection: keep-alive' HTTP header, in which case PORT may be +reused for future HTTP requests. Raise an '&http-get-error' condition if downloading fails." (let loop ((uri (if (string? uri) @@ -246,8 +249,10 @@ Raise an '&http-get-error' condition if downloading fails." ;; Try hard to use the API du jour to get an input port. (if (guile-version>? "2.0.7") (http-get uri #:streaming? #t #:port port + #:keep-alive? #t #:headers auth-header) ; 2.0.9+ (http-get* uri #:decode-body? text? ; 2.0.7 + #:keep-alive? #t #:port port #:headers auth-header))) ((code) (response-code resp))) -- cgit v1.2.3 From 026ca50fa4c46a8e280cd51621bbec76b12c0757 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Mar 2016 22:44:59 +0100 Subject: substitute: Keep the initial connection alive. The connection used to fetch /nix-cache-info is now reused for the subsequent narinfo requests. * guix/scripts/substitute.scm (download-cache-info)[download]: Remove. [uri, read-cache-info]: New variables. Rewrite in terms of 'http-fetch' instead of 'fetch'. Return an open port in addition to a . * guix/scripts/substitute.scm (http-multiple-get): Add #:port parameter and honor it. (fetch-narinfos)[do-fetch]: Add 'port' parameter. Adjust to new 'download-cache-info' and 'do-fetch' signatures. --- guix/scripts/substitute.scm | 95 ++++++++++++++++++++++++++++++--------------- 1 file changed, 64 insertions(+), 31 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index d20c82a770..524d453ffa 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -216,19 +216,46 @@ provide." (wants-mass-query? cache-info-wants-mass-query?)) (define (download-cache-info url) - "Download the information for the cache at URL. Return a -object on success, or #f on failure." - (define (download url) - ;; Download the `nix-cache-info' from URL, and return its contents as an - ;; list of key/value pairs. - (and=> (false-if-exception (fetch (string->uri url))) - fields->alist)) - - (and=> (download (string-append url "/nix-cache-info")) - (lambda (properties) - (alist->record properties - (cut %make-cache-info url <...>) - '("StoreDir" "WantMassQuery"))))) + "Download the information for the cache at URL. On success, return a + object and a port on which to send further HTTP requests. On +failure, return #f and #f." + (define uri + (string->uri (string-append url "/nix-cache-info"))) + + (define (read-cache-info port) + (alist->record (fields->alist port) + (cut %make-cache-info url <...>) + '("StoreDir" "WantMassQuery"))) + + (catch #t + (lambda () + (case (uri-scheme uri) + ((file) + (values (call-with-input-file (uri-path uri) + read-cache-info) + #f)) + ((http https) + (let ((port (open-connection-for-uri uri + #:timeout %fetch-timeout))) + (guard (c ((http-get-error? c) + (warning (_ "while fetching '~a': ~a (~s)~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + (close-port port) + (warning (_ "ignoring substitute server at '~s'~%") url) + (values #f #f))) + (values (read-cache-info (http-fetch uri + #:port port + #:keep-alive? #t)) + port)))))) + (lambda (key . args) + (case key + ((getaddrinfo-error system-error) + ;; Silently ignore the error: probably due to lack of network access. + (values #f #f)) + (else + (apply throw key args)))))) (define-record-type @@ -477,16 +504,19 @@ may be #f, in which case it indicates that PATH is unavailable at CACHE-URL." ".narinfo"))) (build-request (string->uri url) #:method 'GET))) -(define (http-multiple-get base-uri proc seed requests) +(define* (http-multiple-get base-uri proc seed requests + #:key port) "Send all of REQUESTS to the server at BASE-URI. Call PROC for each response, passing it the request object, the response, a port from which to read the response body, and the previous result, starting with SEED, à la -'fold'. Return the final result." - (let connect ((requests requests) +'fold'. Return the final result. When PORT is specified, use it as the +initial connection on which HTTP requests are sent." + (let connect ((port port) + (requests requests) (result seed)) ;; (format (current-error-port) "connecting (~a requests left)..." ;; (length requests)) - (let ((p (open-connection-for-uri base-uri))) + (let ((p (or port (open-connection-for-uri base-uri)))) ;; For HTTPS, P is not a file port and does not support 'setvbuf'. (when (file-port? p) (setvbuf p _IOFBF (expt 2 16))) @@ -520,7 +550,7 @@ read the response body, and the previous result, starting with SEED, à la (match (assq 'connection (response-headers resp)) (('connection 'close) (close-port p) - (connect tail result)) ;try again + (connect #f tail result)) ;try again (_ (loop tail result)))))))))) ;keep going @@ -579,14 +609,17 @@ if file doesn't exist, and the narinfo otherwise." (read-to-eof port)) result)))) - (define (do-fetch uri) + (define (do-fetch uri port) (case (and=> uri uri-scheme) ((http https) (let ((requests (map (cut narinfo-request url <>) paths))) (update-progress!) (let ((result (http-multiple-get uri handle-narinfo-response '() - requests))) + requests + #:port port))) + (unless (port-closed? port) + (close-port port)) (newline (current-error-port)) result))) ((file #f) @@ -599,17 +632,17 @@ if file doesn't exist, and the narinfo otherwise." (leave (_ "~s: unsupported server URI scheme~%") (if uri (uri-scheme uri) url))))) - (define cache-info - (download-cache-info url)) - - (and cache-info - (if (string=? (cache-info-store-directory cache-info) - (%store-prefix)) - (do-fetch (string->uri url)) - (begin - (warning (_ "'~a' uses different store '~a'; ignoring it~%") - url (cache-info-store-directory cache-info)) - #f)))) + (let-values (((cache-info port) + (download-cache-info url))) + (and cache-info + (if (string=? (cache-info-store-directory cache-info) + (%store-prefix)) + (do-fetch (string->uri url) port) ;reuse PORT + (begin + (warning (_ "'~a' uses different store '~a'; ignoring it~%") + url (cache-info-store-directory cache-info)) + (close-port port) + #f))))) (define (lookup-narinfos cache paths) "Return the narinfos for PATHS, invoking the server at CACHE when no -- cgit v1.2.3 From 264fdedb408ba3620d1e361de6c77e7925025301 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Mar 2016 22:49:51 +0100 Subject: grafts: Update the narinfo cache before building a derivation. * guix/grafts.scm (references-oracle)[references*]: Add call to 'substitution-oracle'. --- guix/grafts.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'guix') diff --git a/guix/grafts.scm b/guix/grafts.scm index af469575db..6bec999ad2 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -189,6 +189,12 @@ available." (guard (c ((nix-protocol-error? c) ;; As a last resort, build DRV and query the references of the ;; build result. + + ;; Warm up the narinfo cache, otherwise each derivation build + ;; will result in one HTTP request to get one narinfo, which is + ;; much less efficient than fetching them all upfront. + (substitution-oracle store (list drv)) + (and (build-derivations store (list drv)) (map (cut references store <>) items)))) (references/substitutes store items))) -- cgit v1.2.3 From 409e4ac6e3d86491901a9c0bb422b0415c906964 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Mar 2016 10:20:45 +0100 Subject: http-client: No 'setvbuf' for non-file ports. * guix/http-client.scm (http-fetch): Do not call 'setvbuf' on non-file ports. --- guix/http-client.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/http-client.scm b/guix/http-client.scm index 25693824ed..97a1e26d3e 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -243,7 +243,7 @@ Raise an '&http-get-error' condition if downloading fails." (base64-encode (string->utf8 str)))))) (_ '())))) - (unless buffered? + (unless (or buffered? (not (file-port? port))) (setvbuf port _IONBF)) (let*-values (((resp data) ;; Try hard to use the API du jour to get an input port. -- cgit v1.2.3 From df061d079b50111280aa7209b3b3c4cf21fde218 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Mar 2016 10:35:24 +0100 Subject: build: Default to "https://mirror.hydra.gnu.org/" for substitutes. * config-daemon.ac: Check for (gnutls) and define 'GUIX_SUBSTITUTE_URLS'. * nix/nix-daemon/guix-daemon.cc (main): Use GUIX_SUBSTITUTE_URLS. * guix/store.scm (%default-substitute-urls): Use 'https' when (gnutls) is available. * doc/guix.texi (Binary Installation): Mention mirrors (Invoking guix-daemon): Mention mirror.hydra.gnu.org. (Substitutes): Mention mirrors. (Invoking guix archive): Show https URLs. --- config-daemon.ac | 14 ++++++++++++++ doc/guix.texi | 16 +++++++++------- guix/store.scm | 8 ++++++-- nix/nix-daemon/guix-daemon.cc | 4 ++-- 4 files changed, 31 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/config-daemon.ac b/config-daemon.ac index c74ec94d31..63174d62c7 100644 --- a/config-daemon.ac +++ b/config-daemon.ac @@ -110,6 +110,20 @@ if test "x$guix_build_daemon" = "xyes"; then dnl Check for (for immutable file support). AC_CHECK_HEADERS([linux/fs.h]) + dnl Determine the appropriate default list of substitute URLs. + GUILE_MODULE_AVAILABLE([have_gnutls], [(gnutls)]) + if test "x$have_gnutls" = "xyes"; then + guix_substitute_urls="https://mirror.hydra.gnu.org https://hydra.gnu.org" + else + AC_MSG_WARN([GnuTLS is missing, substitutes will be downloaded in the clear]) + guix_substitute_urls="http://mirror.hydra.gnu.org http://hydra.gnu.org" + fi + AC_MSG_CHECKING([for default substitute URLs]) + AC_MSG_RESULT([$guix_substitute_urls]) + + AC_DEFINE_UNQUOTED([GUIX_SUBSTITUTE_URLS], ["$guix_substitute_urls"], + [Default list of substitute URLs used by 'guix-daemon'.]) + 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.) diff --git a/doc/guix.texi b/doc/guix.texi index 438189fb34..05ce7858d5 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -448,8 +448,8 @@ Directories,,, texinfo, GNU Texinfo}, for more details on changing the Info search path.) @item -To use substitutes from @code{hydra.gnu.org} (@pxref{Substitutes}), -authorize them: +To use substitutes from @code{hydra.gnu.org} or one of its mirrors +(@pxref{Substitutes}), authorize them: @example # guix archive --authorize < ~root/.guix-profile/share/guix/hydra.gnu.org.pub @@ -912,8 +912,9 @@ remote procedure call (@pxref{The Store}). @item --substitute-urls=@var{urls} @anchor{daemon-substitute-urls} Consider @var{urls} the default whitespace-separated list of substitute -source URLs. When this option is omitted, @indicateurl{http://hydra.gnu.org} -is used. +source URLs. When this option is omitted, +@indicateurl{https://mirror.hydra.gnu.org https://hydra.gnu.org} is used +(@code{mirror.hydra.gnu.org} is a mirror of @code{hydra.gnu.org}). This means that substitutes may be downloaded from @var{urls}, as long as they are signed by a trusted signature (@pxref{Substitutes}). @@ -1730,7 +1731,8 @@ your system has unpatched security vulnerabilities. @cindex security @cindex digital signatures -To allow Guix to download substitutes from @code{hydra.gnu.org}, you +To allow Guix to download substitutes from @code{hydra.gnu.org} or a +mirror thereof, you must add its public key to the access control list (ACL) of archive imports, using the @command{guix archive} command (@pxref{Invoking guix archive}). Doing so implies that you trust @code{hydra.gnu.org} to not @@ -2199,7 +2201,7 @@ served by @code{hydra.gnu.org} to @file{/tmp/emacs}: @example $ wget -O - \ - http://hydra.gnu.org/nar/@dots{}-emacs-24.5 \ + https://hydra.gnu.org/nar/@dots{}-emacs-24.5 \ | bunzip2 | guix archive -x /tmp/emacs @end example @@ -4294,7 +4296,7 @@ but you are actually on an @code{x86_64} machine: @example $ guix build --log-file gdb -s mips64el-linux -http://hydra.gnu.org/log/@dots{}-gdb-7.10 +https://hydra.gnu.org/log/@dots{}-gdb-7.10 @end example You can freely access a huge library of build logs! diff --git a/guix/store.scm b/guix/store.scm index 01248738dc..ae52628545 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -504,8 +504,12 @@ encoding conversion errors." (status k)))))))) (define %default-substitute-urls - ;; Default list of substituters. - '("http://hydra.gnu.org")) + ;; Default list of substituters. This is *not* the list used by + ;; 'guix-daemon', and few clients use it ('guix build --log-file' uses it.) + (map (if (false-if-exception (resolve-interface '(gnutls))) + (cut string-append "https://" <>) + (cut string-append "http://" <>)) + '("hydra.gnu.org"))) (define* (set-build-options server #:key keep-failed? keep-going? fallback? diff --git a/nix/nix-daemon/guix-daemon.cc b/nix/nix-daemon/guix-daemon.cc index 20a0732fcb..d5d33a587a 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, 2014, 2015 Ludovic Courtès + Copyright (C) 2012, 2013, 2014, 2015, 2016 Ludovic Courtès This file is part of GNU Guix. @@ -327,7 +327,7 @@ main (int argc, char *argv[]) settings.set ("build-use-substitutes", "true"); /* Use our substitute server by default. */ - settings.set ("substitute-urls", "http://hydra.gnu.org"); + settings.set ("substitute-urls", GUIX_SUBSTITUTE_URLS); #ifdef HAVE_DAEMON_OFFLOAD_HOOK /* Use our build hook for distributed builds by default. */ -- cgit v1.2.3 From 1cf7e31898ba444c7c1614aa5d5680806b60442a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Mar 2016 14:51:37 +0100 Subject: substitute: Make room for a 'ttl' field in cached entries. * guix/scripts/substitute.scm (cached-narinfo): Expect 'narinfo' sexp version 2 with a 'ttl' field. (cache-narinfo!)[cache-entry]: Produce 'narinfo' sexp version 2 with a 'ttl' field. (remove-expired-cached-narinfos)[expired?]: Read 'narinfo' sexp version 2. --- guix/scripts/substitute.scm | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 524d453ffa..4b009d8c81 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -452,18 +452,18 @@ for PATH." (call-with-input-file cache-file (lambda (p) (match (read p) - (('narinfo ('version 1) + (('narinfo ('version 2) ('cache-uri cache-uri) - ('date date) ('value #f)) + ('date date) ('ttl _) ('value #f)) ;; A cached negative lookup. (if (obsolete? date now %narinfo-negative-ttl) (values #f #f) (values #t #f))) - (('narinfo ('version 1) + (('narinfo ('version 2) ('cache-uri cache-uri) - ('date date) ('value value)) + ('date date) ('ttl ttl) ('value value)) ;; A cached positive lookup - (if (obsolete? date now %narinfo-ttl) + (if (obsolete? date now ttl) (values #f #f) (values #t (string->narinfo value cache-uri)))) (('narinfo ('version v) _ ...) @@ -478,9 +478,10 @@ may be #f, in which case it indicates that PATH is unavailable at CACHE-URL." (current-time time-monotonic)) (define (cache-entry cache-uri narinfo) - `(narinfo (version 1) + `(narinfo (version 2) (cache-uri ,cache-uri) (date ,(time-second now)) + (ttl ,%narinfo-ttl) ;TODO: Make this per-entry. (value ,(and=> narinfo narinfo->string)))) (let ((file (narinfo-cache-file cache-url path))) @@ -704,12 +705,12 @@ indefinitely." (call-with-input-file file (lambda (port) (match (read port) - (('narinfo ('version 1) ('cache-uri _) ('date date) - ('value #f)) + (('narinfo ('version 2) ('cache-uri _) + ('date date) ('ttl _) ('value #f)) (obsolete? date now %narinfo-negative-ttl)) - (('narinfo ('version 1) ('cache-uri _) ('date date) - ('value _)) - (obsolete? date now %narinfo-ttl)) + (('narinfo ('version 2) ('cache-uri _) + ('date date) ('ttl ttl) ('value _)) + (obsolete? date now ttl)) (_ #t))))) (lambda args ;; FILE may have been deleted. -- cgit v1.2.3 From 23d60ba65c137abf472a25db7317154abfc4af4d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Mar 2016 15:31:18 +0100 Subject: substitute: Honor the 'max-age' of 'Cache-Control' headers. This allows substitute servers to tell 'guix substitute' how long they can cache narinfo lookups. * guix/scripts/substitute.scm (cache-narinfo!): Add 'ttl' parameter. [cache-entry]: Honor it. (fetch-narinfos)[handle-narinfo-response]: Check the 'Cache-Control' header of RESPONSE and pass its 'max-age' value to 'cache-narinfo!'. --- guix/scripts/substitute.scm | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 4b009d8c81..b707accff6 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -108,9 +108,8 @@ disabled!~%")) (define %narinfo-ttl ;; Number of seconds during which cached narinfo lookups are considered - ;; valid. This is a reasonable default value (corresponds to the TTL for - ;; nginx's .nar cache on hydra.gnu.org) but we'd rather want publishers to - ;; state what their TTL is in /nix-cache-info. (XXX) + ;; valid for substitute servers that do not advertise a TTL via the + ;; 'Cache-Control' response header. (* 36 3600)) (define %narinfo-negative-ttl @@ -471,9 +470,10 @@ for PATH." (lambda _ (values #f #f)))) -(define (cache-narinfo! cache-url path narinfo) - "Cache locally NARNIFO for PATH, which originates from CACHE-URL. NARINFO -may be #f, in which case it indicates that PATH is unavailable at CACHE-URL." +(define (cache-narinfo! cache-url path narinfo ttl) + "Cache locally NARNIFO for PATH, which originates from CACHE-URL, with the +given TTL (a number of seconds or #f). NARINFO may be #f, in which case it +indicates that PATH is unavailable at CACHE-URL." (define now (current-time time-monotonic)) @@ -481,7 +481,8 @@ may be #f, in which case it indicates that PATH is unavailable at CACHE-URL." `(narinfo (version 2) (cache-uri ,cache-uri) (date ,(time-second now)) - (ttl ,%narinfo-ttl) ;TODO: Make this per-entry. + (ttl ,(or ttl + (if narinfo %narinfo-ttl %narinfo-negative-ttl))) (value ,(and=> narinfo narinfo->string)))) (let ((file (narinfo-cache-file cache-url path))) @@ -584,13 +585,15 @@ if file doesn't exist, and the narinfo otherwise." (set! done (+ 1 done))))) (define (handle-narinfo-response request response port result) - (let ((len (response-content-length response))) + (let* ((len (response-content-length response)) + (cache (response-cache-control response)) + (ttl (and cache (assoc-ref cache 'max-age)))) ;; Make sure to read no more than LEN bytes since subsequent bytes may ;; belong to the next response. (case (response-code response) ((200) ; hit (let ((narinfo (read-narinfo port url #:size len))) - (cache-narinfo! url (narinfo-path narinfo) narinfo) + (cache-narinfo! url (narinfo-path narinfo) narinfo ttl) (update-progress!) (cons narinfo result))) ((404) ; failure @@ -601,7 +604,7 @@ if file doesn't exist, and the narinfo otherwise." (read-to-eof port)) (cache-narinfo! url (find (cut string-contains <> hash-part) paths) - #f) + #f ttl) (update-progress!) result)) (else ; transient failure -- cgit v1.2.3 From 71e2065a38cf2641b7eb8c557b0f043f5a42a649 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Mar 2016 18:13:02 +0100 Subject: substitute: Honor client-provided empty URL list. Before that, 'guix build --substitute-urls=""' would lead to using the daemon's own URL list instead of the empty list. The 'or*' hack, which is to blame, had become unnecessary since commit fb4bf72be3fbc23bca35ba4b842b7e1517ef0e3a. Reported by Mark H Weaver . * guix/scripts/substitute.scm (or*): Remove. (%cache-urls): Use 'or' instead of 'or*'. * tests/store.scm ("substitute query, alternating URLs"): Add test with empty URL list. * doc/guix.texi (Common Build Options): Mention the empty string. --- doc/guix.texi | 3 +++ guix/scripts/substitute.scm | 10 ++-------- tests/store.scm | 6 +++++- 3 files changed, 10 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 05ce7858d5..ba4fe1a826 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3983,6 +3983,9 @@ This means that substitutes may be downloaded from @var{urls}, provided they are signed by a key authorized by the system administrator (@pxref{Substitutes}). +When @var{urls} is the empty string, substitutes are effectively +disabled. + @item --no-substitutes Do not use substitutes for build products. That is, always build things locally instead of allowing downloads of pre-built binaries diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index b707accff6..1ab18d0260 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -953,15 +953,9 @@ substitutes may be unavailable\n"))))) found." (assoc-ref (daemon-options) option)) -(define-syntax-rule (or* a b) - (let ((first a)) - (if (or (not first) (string-null? first)) - b - first))) - (define %cache-urls - (match (and=> (or* (find-daemon-option "untrusted-substitute-urls") ;client - (find-daemon-option "substitute-urls")) ;admin + (match (and=> (or (find-daemon-option "untrusted-substitute-urls") ;client + (find-daemon-option "substitute-urls")) ;admin string-tokenize) ((urls ...) urls) diff --git a/tests/store.scm b/tests/store.scm index 3d32d52758..f7db7df966 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -450,7 +450,11 @@ (with-store s ;the right one again (set-build-options s #:use-substitutes? #t #:substitute-urls (%test-substitute-urls)) - (has-substitutes? s o)))))) + (has-substitutes? s o)) + (with-store s ;empty list of URLs + (set-build-options s #:use-substitutes? #t + #:substitute-urls '()) + (not (has-substitutes? s o))))))) (test-assert "substitute" (with-store s -- cgit v1.2.3 From f88ce395e6d4c089462e44baa28191d530ed97c5 Mon Sep 17 00:00:00 2001 From: Roel Janssen Date: Wed, 16 Mar 2016 08:50:23 +0100 Subject: licenses: Add Apache Software License 1.1. * guix/licenses.scm (asl1.1): New variables. Signed-off-by: Leo Famulari --- guix/licenses.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index 61e679358a..71c0736223 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -28,7 +28,7 @@ #:use-module (srfi srfi-9) #:export (license? license-name license-uri license-comment agpl3 agpl3+ - asl2.0 + asl1.1 asl2.0 boost1.0 bsd-2 bsd-3 bsd-4 non-copyleft @@ -100,6 +100,11 @@ "https://gnu.org/licenses/agpl.html" "https://gnu.org/licenses/why-affero-gpl.html")) +(define asl1.1 + (license "ASL 1.1" + "http://directory.fsf.org/wiki/License:Apache1.1" + "https://www.gnu.org/licenses/license-list#apache1")) + (define asl2.0 (license "ASL 2.0" "http://directory.fsf.org/wiki/License:Apache2.0" -- cgit v1.2.3 From fc3ea24bf44d2d47dfb2ba8b1ac4d3a971f5e4c4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 17 Mar 2016 15:35:55 +0100 Subject: substitute: Update progress for responses different from 200/404. * guix/scripts/substitute.scm (fetch-narinfos)[handle-narinfo-response]: Add missing call to 'update-progress!'. --- guix/scripts/substitute.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 1ab18d0260..efbcfe78ca 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -607,10 +607,11 @@ if file doesn't exist, and the narinfo otherwise." #f ttl) (update-progress!) result)) - (else ; transient failure + (else ; transient failure: 504... (if len (get-bytevector-n port len) (read-to-eof port)) + (update-progress!) result)))) (define (do-fetch uri port) -- cgit v1.2.3 From 097a951e96718a037dbfa6d579e2d26f7dab3e82 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 17 Mar 2016 21:34:33 +0100 Subject: download: Add 'close-connection'. Partially fixes . * guix/build/download.scm (add-weak-reference): Remove. (%tls-ports): New variable. (register-tls-record-port): New procedure. (tls-wrap): Use it instead of 'add-weak-reference'. (close-connection): New procedure. --- guix/build/download.scm | 32 ++++++++++++++++++++++++-------- 1 file changed, 24 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 8843804c40..0568800d7f 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2015 Steve Sprang ;;; @@ -34,6 +34,7 @@ #:use-module (ice-9 format) #:export (open-socket-for-uri open-connection-for-uri + close-connection resolve-uri-reference maybe-expand-mirrors url-fetch @@ -236,11 +237,14 @@ abbreviation of URI showing the scheme, host, and basename of the file." (module-autoload! (current-module) '(gnutls) '(make-session connection-end/client)) -(define add-weak-reference - (let ((table (make-weak-key-hash-table))) - (lambda (from to) - "Hold a weak reference from FROM to TO." - (hashq-set! table from to)))) +(define %tls-ports + ;; Mapping of session record ports to the underlying file port. + (make-weak-key-hash-table)) + +(define (register-tls-record-port record-port port) + "Hold a weak reference from RECORD-PORT to PORT, where RECORD-PORT is a TLS +session record port using PORT as its underlying communication port." + (hashq-set! %tls-ports record-port port)) (define (tls-wrap port server) "Return PORT wrapped in a TLS connection to SERVER. SERVER must be a DNS @@ -275,7 +279,7 @@ host name without trailing dot." ;; closed when PORT is GC'd. If we used `port->fdes', it would instead ;; never be closed. So we use `fileno', but keep a weak reference to ;; PORT, so the file descriptor gets closed when RECORD is GC'd. - (add-weak-reference record port) + (register-tls-record-port record port) record))) (define (ensure-uri uri-or-string) ;XXX: copied from (web http) @@ -337,7 +341,8 @@ ETIMEDOUT error is raised." (loop (cdr addresses)))))))) (define* (open-connection-for-uri uri #:key timeout) - "Like 'open-socket-for-uri', but also handle HTTPS connections." + "Like 'open-socket-for-uri', but also handle HTTPS connections. The +resulting port must be closed with 'close-connection'." (define https? (eq? 'https (uri-scheme uri))) @@ -367,6 +372,17 @@ ETIMEDOUT error is raised." (tls-wrap s (uri-host uri)) s))))) +(define (close-connection port) + "Like 'close-port', but (1) idempotent, and (2) also closes the underlying +port if PORT is a TLS session record port." + ;; FIXME: This is a partial workaround for , + ;; because 'http-fetch' & co. may return a chunked input port whose 'close' + ;; method calls 'close-port', not 'close-connection'. + (unless (port-closed? port) + (close-port port)) + (and=> (hashq-ref %tls-ports port) + close-connection)) + ;; XXX: This is an awful hack to make sure the (set-port-encoding! p ;; "ISO-8859-1") call in `read-response' passes, even during bootstrap ;; where iconv is not available. -- cgit v1.2.3 From 14d6ca3e4dd23ee92adb5e2fcf58546e67534631 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 17 Mar 2016 21:36:22 +0100 Subject: lint: Do not leak file descriptors for TLS connections. Partially fixes . * guix/scripts/lint.scm (probe-uri): Use 'close-connection' instead of 'close-port'. --- guix/scripts/lint.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index f135bde9df..27b9e155ec 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -20,7 +20,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix scripts lint) - #:use-module (guix store) + #:use-module ((guix store) #:hide (close-connection)) #:use-module (guix base32) #:use-module (guix download) #:use-module (guix ftp-client) @@ -41,7 +41,8 @@ #:use-module (web uri) #:use-module ((guix build download) #:select (maybe-expand-mirrors - open-connection-for-uri)) + open-connection-for-uri + close-connection)) #:use-module (web request) #:use-module (web response) #:use-module (srfi srfi-1) @@ -296,7 +297,7 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." (force-output port) (read-response port)) (lambda () - (close port)))) + (close-connection port)))) (case (response-code response) ((301 302 307) -- cgit v1.2.3 From 958fb14cdb5970ecf846e7b85c076a8ed3fe093b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 17 Mar 2016 21:49:05 +0100 Subject: substitute: Cache transient HTTP errors for 10mn. * guix/scripts/substitute.scm (fetch-narinfos)[handle-narinfo-response]: Cache transient errors for 10mn. (%narinfo-transient-error-ttl): New variable. --- guix/scripts/substitute.scm | 50 ++++++++++++++++++++++----------------------- 1 file changed, 25 insertions(+), 25 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index efbcfe78ca..c9e2ca3b83 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -113,9 +113,13 @@ disabled!~%")) (* 36 3600)) (define %narinfo-negative-ttl - ;; Likewise, but for negative lookups---i.e., cached lookup failures. + ;; Likewise, but for negative lookups---i.e., cached lookup failures (404). (* 3 3600)) +(define %narinfo-transient-error-ttl + ;; Likewise, but for transient errors such as 504 ("Gateway timeout"). + (* 10 60)) + (define %narinfo-expired-cache-entry-removal-delay ;; How often we want to remove files corresponding to expired cache entries. (* 7 24 3600)) @@ -585,34 +589,30 @@ if file doesn't exist, and the narinfo otherwise." (set! done (+ 1 done))))) (define (handle-narinfo-response request response port result) - (let* ((len (response-content-length response)) + (let* ((code (response-code response)) + (len (response-content-length response)) (cache (response-cache-control response)) (ttl (and cache (assoc-ref cache 'max-age)))) ;; Make sure to read no more than LEN bytes since subsequent bytes may ;; belong to the next response. - (case (response-code response) - ((200) ; hit - (let ((narinfo (read-narinfo port url #:size len))) - (cache-narinfo! url (narinfo-path narinfo) narinfo ttl) - (update-progress!) - (cons narinfo result))) - ((404) ; failure - (let* ((path (uri-path (request-uri request))) - (hash-part (string-drop-right path 8))) ; drop ".narinfo" - (if len - (get-bytevector-n port len) - (read-to-eof port)) - (cache-narinfo! url - (find (cut string-contains <> hash-part) paths) - #f ttl) - (update-progress!) - result)) - (else ; transient failure: 504... - (if len - (get-bytevector-n port len) - (read-to-eof port)) - (update-progress!) - result)))) + (if (= code 200) ; hit + (let ((narinfo (read-narinfo port url #:size len))) + (cache-narinfo! url (narinfo-path narinfo) narinfo ttl) + (update-progress!) + (cons narinfo result)) + (let* ((path (uri-path (request-uri request))) + (hash-part (string-drop-right path 8))) ; drop ".narinfo" + (if len + (get-bytevector-n port len) + (read-to-eof port)) + (cache-narinfo! url + (find (cut string-contains <> hash-part) paths) + #f + (if (= 404 code) + ttl + %narinfo-transient-error-ttl)) + (update-progress!) + result)))) (define (do-fetch uri port) (case (and=> uri uri-scheme) -- cgit v1.2.3 From b879b3e848d9cf4f4cc39ba8164f8b6be346313c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 17 Mar 2016 21:57:15 +0100 Subject: substitute: Do not leak file descriptors for TLS connections. Partially fixes . * guix/scripts/substitute.scm (fetch, download-cache-info): (http-multiple-get, fetch-narinfos, progress-report-port): Use 'close-connection' instead of 'close-port'. --- guix/scripts/substitute.scm | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index c9e2ca3b83..4563f3df0f 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -19,7 +19,7 @@ (define-module (guix scripts substitute) #:use-module (guix ui) - #:use-module (guix store) + #:use-module ((guix store) #:hide (close-connection)) #:use-module (guix utils) #:use-module (guix config) #:use-module (guix records) @@ -33,6 +33,7 @@ #:use-module ((guix build download) #:select (progress-proc uri-abbreviation open-connection-for-uri + close-connection store-path-abbreviation byte-count->string)) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) @@ -200,7 +201,7 @@ provide." (unless (or (guile-version>? "2.0.9") (version>? (version) "2.0.9.39")) (when port - (close-port port)))) + (close-connection port)))) (begin (when (or (not port) (port-closed? port)) (set! port (open-connection-for-uri uri)) @@ -245,7 +246,7 @@ failure, return #f and #f." (uri->string (http-get-error-uri c)) (http-get-error-code c) (http-get-error-reason c)) - (close-port port) + (close-connection port) (warning (_ "ignoring substitute server at '~s'~%") url) (values #f #f))) (values (read-cache-info (http-fetch uri @@ -555,7 +556,7 @@ initial connection on which HTTP requests are sent." ;; Note that even upon "Connection: close", we can read from BODY. (match (assq 'connection (response-headers resp)) (('connection 'close) - (close-port p) + (close-connection p) (connect #f tail result)) ;try again (_ (loop tail result)))))))))) ;keep going @@ -623,8 +624,7 @@ if file doesn't exist, and the narinfo otherwise." handle-narinfo-response '() requests #:port port))) - (unless (port-closed? port) - (close-port port)) + (close-connection port) (newline (current-error-port)) result))) ((file #f) @@ -646,7 +646,7 @@ if file doesn't exist, and the narinfo otherwise." (begin (warning (_ "'~a' uses different store '~a'; ignoring it~%") url (cache-info-store-directory cache-info)) - (close-port port) + (close-connection port) #f))))) (define (lookup-narinfos cache paths) @@ -776,7 +776,7 @@ PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by (make-custom-binary-input-port "progress-port-proc" read! #f #f - (cut close-port port))) + (cut close-connection port))) (define-syntax with-networking (syntax-rules () -- cgit v1.2.3 From 522773b70024272555aab0448fae8606add4c582 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 19 Mar 2016 23:49:59 +0100 Subject: import: pypi: Emit 'pypi-uri' only when it yields the right URL. Fixes . Reported by Danny Milosavljevic . * guix/import/pypi.scm (make-pypi-sexp): Check whether 'pypi-uri' returns SOURCE-URL and fall back to the full URL otherwise. * tests/pypi.scm ("pypi->guix-package"): Adjust expected URI accordingly. Co-authored-by: Danny Milosavljevic --- guix/import/pypi.scm | 12 ++++++++++-- tests/pypi.scm | 3 ++- 2 files changed, 12 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index d54bb9fbba..8ae4948147 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson ;;; Copyright © 2015 Cyril Roelandt -;;; Copyright © 2015 Ludovic Courtès +;;; Copyright © 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -194,7 +194,15 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (version ,version) (source (origin (method url-fetch) - (uri (pypi-uri ,name version)) + + ;; Sometimes 'pypi-uri' doesn't quite work due to mixed + ;; cases in NAME, for instance, as is the case with + ;; "uwsgi". In that case, fall back to a full URL. + (uri ,(if (equal? (pypi-uri name version) source-url) + `(pypi-uri ,name version) + `(string-append + ,@(factorize-uri source-url version)))) + (sha256 (base32 ,(guix-hash-url temp))))) diff --git a/tests/pypi.scm b/tests/pypi.scm index 960b8cd32a..cf351a542f 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -84,7 +84,8 @@ baz > 13.37") ('version "1.0.0") ('source ('origin ('method 'url-fetch) - ('uri (pypi-uri "foo" version)) + ('uri (string-append "https://example.com/foo-" + version ".tar.gz")) ('sha256 ('base32 (? string? hash))))) -- cgit v1.2.3 From 35b5ca7869396b8d37539b9279147c100eee12f1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 20 Mar 2016 22:40:31 +0100 Subject: derivations: Add #:disallowed-references. * guix/derivations.scm (derivation): Add #:disallowed-references. [user+system-env-vars]: Honor it. (build-expression->derivation): Likewise. * tests/derivations.scm ("derivation #:disallowed-references, ok") ("derivation #:disallowed-references, not ok"): New tests. * doc/guix.texi (Derivations): Adjust accordingly. --- doc/guix.texi | 13 +++++++++---- guix/derivations.scm | 16 ++++++++++++---- tests/derivations.scm | 19 +++++++++++++++++++ 3 files changed, 40 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 868948adfc..075839eadf 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3075,7 +3075,8 @@ a derivation is the @code{derivation} procedure: @var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @ [#:recursive? #f] [#:inputs '()] [#:env-vars '()] @ [#:system (%current-system)] [#:references-graphs #f] @ - [#:allowed-references #f] [#:leaked-env-vars #f] [#:local-build? #f] @ + [#:allowed-references #f] [#:disallowed-references #f] @ + [#:leaked-env-vars #f] [#:local-build? #f] @ [#:substitutable? #t] Build a derivation with the given arguments, and return the resulting @code{} object. @@ -3093,7 +3094,9 @@ path is exported in the build environment in the corresponding file, in a simple text format. When @var{allowed-references} is true, it must be a list of store items -or outputs that the derivation's output may refer to. +or outputs that the derivation's output may refer to. Likewise, +@var{disallowed-references}, if true, must be a list of things the +outputs may @emph{not} refer to. When @var{leaked-env-vars} is true, it must be a list of strings denoting environment variables that are allowed to ``leak'' from the @@ -3150,6 +3153,7 @@ is now deprecated in favor of the much nicer @code{gexp->derivation}. [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @ [#:recursive? #f] [#:env-vars '()] [#:modules '()] @ [#:references-graphs #f] [#:allowed-references #f] @ + [#:disallowed-references #f] @ [#:local-build? #f] [#:substitutable? #t] [#: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 @@ -3173,8 +3177,9 @@ terminates by passing the result of @var{exp} to @code{exit}; thus, when @code{%guile-for-build} fluid is used instead. See the @code{derivation} procedure for the meaning of -@var{references-graphs}, @var{allowed-references}, @var{local-build?}, -and @var{substitutable?}. +@var{references-graphs}, @var{allowed-references}, +@var{disallowed-references}, @var{local-build?}, and +@var{substitutable?}. @end deffn @noindent diff --git a/guix/derivations.scm b/guix/derivations.scm index 1164774009..f24e3c6f92 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -695,7 +695,8 @@ HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for (system (%current-system)) (env-vars '()) (inputs '()) (outputs '("out")) hash hash-algo recursive? - references-graphs allowed-references + references-graphs + allowed-references disallowed-references leaked-env-vars local-build? (substitutable? #t)) "Build a derivation with the given arguments, and return the resulting @@ -710,7 +711,8 @@ 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 ALLOWED-REFERENCES is true, it must be a list of store items or outputs -that the derivation's output may refer to. +that the derivation's outputs may refer to. Likewise, DISALLOWED-REFERENCES, +if true, must be a list of things the outputs may not refer to. When LEAKED-ENV-VARS is true, it must be a list of strings denoting environment variables that are allowed to \"leak\" from the daemon's @@ -768,6 +770,10 @@ output should not be used." `(("allowedReferences" . ,(string-join allowed-references))) '()) + ,@(if disallowed-references + `(("disallowedReferences" + . ,(string-join disallowed-references))) + '()) ,@(if leaked-env-vars `(("impureEnvVars" . ,(string-join leaked-env-vars))) @@ -1112,6 +1118,7 @@ they can refer to each other." guile-for-build references-graphs allowed-references + disallowed-references local-build? (substitutable? #t)) "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) @@ -1132,7 +1139,7 @@ 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, -ALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." +ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." (define guile-drv (or guile-for-build (%guile-for-build))) @@ -1258,6 +1265,7 @@ ALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?." #:outputs outputs #:references-graphs references-graphs #:allowed-references allowed-references + #:disallowed-references disallowed-references #:local-build? local-build? #:substitutable? substitutable?))) diff --git a/tests/derivations.scm b/tests/derivations.scm index 3c35218040..4d3b82fe1a 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -504,6 +504,25 @@ (build-derivations %store (list drv)) #f))) +(test-assert "derivation #:disallowed-references, ok" + (let ((drv (derivation %store "disallowed" %bash + '("-c" "echo hello > $out") + #:inputs `((,%bash)) + #:disallowed-references '("out")))) + (build-derivations %store (list drv)))) + +(test-assert "derivation #:disallowed-references, not ok" + (let* ((txt (add-text-to-store %store "foo" "Hello, world.")) + (drv (derivation %store "disdisallowed" %bash + `("-c" ,(string-append "echo " txt "> $out")) + #:inputs `((,%bash) (,txt)) + #:disallowed-references (list txt)))) + (guard (c ((nix-protocol-error? c) + ;; There's no specific error message to check for. + #t)) + (build-derivations %store (list drv)) + #f))) + ;; Here we should get the value of $NIX_STATE_DIR that the daemon sees, which ;; is a unique value for each test process; this value is the same as the one ;; we see in the process executing this file since it is set by 'test-env'. -- cgit v1.2.3 From 3f4ecf32291779d9f75493a5e75cdbea2bc51adb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 20 Mar 2016 22:44:03 +0100 Subject: gexp: Add #:disallowed-references. * guix/gexp.scm (gexp->derivation): Add #:disallowed-references and honor it. * tests/gexp.scm ("gexp->derivation #:disallowed-references, allowed") ("gexp->derivation #:disallowed-references"): New tests. * doc/guix.texi (G-Expressions): Adjust accordingly. --- doc/guix.texi | 3 +++ guix/gexp.scm | 10 +++++++++- tests/gexp.scm | 24 ++++++++++++++++++++++++ 3 files changed, 36 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 075839eadf..913545f1a7 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3670,6 +3670,7 @@ information about monads.) [#:recursive? #f] [#:env-vars '()] [#:modules '()] @ [#:module-path @var{%load-path}] @ [#:references-graphs #f] [#:allowed-references #f] @ + [#:disallowed-references #f] @ [#:leaked-env-vars #f] @ [#:script-name (string-append @var{name} "-builder")] @ [#:local-build? #f] [#:substitutable? #t] [#:guile-for-build #f] @@ -3707,6 +3708,8 @@ text format. @var{allowed-references} must be either @code{#f} or a list of output names and packages. In the latter case, the list denotes store items that the result is allowed to refer to. Any reference to another store item will lead to a build error. +Similarly for @var{disallowed-references}, which can list items that must not be +referenced by the outputs. The other arguments are as for @code{derivation} (@pxref{Derivations}). @end deffn diff --git a/guix/gexp.scm b/guix/gexp.scm index 87bc316f97..7cbc79c31c 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -463,7 +463,7 @@ names and file names suitable for the #:allowed-references argument to (guile-for-build (%guile-for-build)) (graft? (%graft?)) references-graphs - allowed-references + allowed-references disallowed-references leaked-env-vars local-build? (substitutable? #t) (script-name (string-append name "-builder"))) @@ -497,6 +497,8 @@ text format. ALLOWED-REFERENCES must be either #f or a list of output names and packages. In the latter case, the list denotes store items that the result is allowed to refer to. Any reference to another store item will lead to a build error. +Similarly for DISALLOWED-REFERENCES, which can list items that must not be +referenced by the outputs. The other arguments are as for 'derivation'." (define %modules modules) @@ -557,6 +559,11 @@ The other arguments are as for 'derivation'." #:system system #:target target) (return #f))) + (disallowed (if disallowed-references + (lower-references disallowed-references + #:system system + #:target target) + (return #f))) (guile (if guile-for-build (return guile-for-build) (default-guile-derivation system)))) @@ -585,6 +592,7 @@ The other arguments are as for 'derivation'." #:hash hash #:hash-algo hash-algo #:recursive? recursive? #:references-graphs (and=> graphs graphs-file-names) #:allowed-references allowed + #:disallowed-references disallowed #:leaked-env-vars leaked-env-vars #:local-build? local-build? #:substitutable? substitutable?)))) diff --git a/tests/gexp.scm b/tests/gexp.scm index d343dc3329..75b907abee 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -600,6 +600,30 @@ (build-derivations %store (list drv)) #f))) +(test-assertm "gexp->derivation #:disallowed-references, allowed" + (mlet %store-monad ((drv (gexp->derivation "disallowed-refs" + #~(begin + (mkdir #$output) + (chdir #$output) + (symlink #$output "self") + (symlink #$%bootstrap-guile + "guile")) + #:disallowed-references '()))) + (built-derivations (list drv)))) + + +(test-assert "gexp->derivation #:disallowed-references" + (let ((drv (run-with-store %store + (gexp->derivation "disallowed-refs" + #~(begin + (mkdir #$output) + (chdir #$output) + (symlink #$%bootstrap-guile "guile")) + #:disallowed-references (list %bootstrap-guile))))) + (guard (c ((nix-protocol-error? c) #t)) + (build-derivations %store (list drv)) + #f))) + (define shebang (string-append "#!" (derivation->output-path (%guile-for-build)) "/bin/guile --no-auto-compile")) -- cgit v1.2.3 From 55e1f25d89bd3cf68cb91be315ac1961ab984042 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 20 Mar 2016 22:46:45 +0100 Subject: build-system/gnu: Add #:disallowed-references. * guix/build-system/gnu.scm (gnu-build): Add #:disallowed-references and honor it. (gnu-cross-build): Likewise. --- guix/build-system/gnu.scm | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index afd57668e2..a7d1952b57 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -296,7 +296,8 @@ standard packages used as implicit inputs of the GNU build system." (imported-modules %gnu-build-system-modules) (modules %default-modules) (substitutable? #t) - allowed-references) + allowed-references + disallowed-references) "Return a derivation called NAME that builds from tarball SOURCE, with input derivation INPUTS, using the usual procedure of the GNU Build System. The builder is run with GUILE, or with the distro's final Guile @@ -313,7 +314,8 @@ SUBSTITUTABLE? determines whether users may be able to use substitutes of the returned derivations, or whether they should always build it locally. ALLOWED-REFERENCES can be either #f, or a list of packages that the outputs -are allowed to refer to." +are allowed to refer to. Likewise for DISALLOWED-REFERENCES, which lists +packages that must not be referenced." (define canonicalize-reference (match-lambda ((? package? p) @@ -378,6 +380,10 @@ are allowed to refer to." (and allowed-references (map canonicalize-reference allowed-references)) + #:disallowed-references + (and disallowed-references + (map canonicalize-reference + disallowed-references)) #:guile-for-build guile-for-build)) @@ -432,7 +438,8 @@ is one of `host' or `target'." (imported-modules %gnu-build-system-modules) (modules %default-modules) (substitutable? #t) - allowed-references) + allowed-references + disallowed-references) "Cross-build NAME for TARGET, where TARGET is a GNU triplet. INPUTS are cross-built inputs, and NATIVE-INPUTS are inputs that run on the build platform." @@ -524,6 +531,10 @@ platform." (and allowed-references (map canonicalize-reference allowed-references)) + #:disallowed-references + (and disallowed-references + (map canonicalize-reference + disallowed-references)) #:guile-for-build guile-for-build)) (define gnu-build-system -- cgit v1.2.3