From 148585c240f848ad08f6541ede7db3fca3411007 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Tue, 13 Jun 2017 00:10:01 +0530 Subject: gnu: Move contents of zip module into compression module. * gnu/packages/zip.scm (zip, unzip, zziplib, perl-zip): Move to... * gnu/packages/compression.scm: ...here. * gnu/packages/zip.scm: Delete file. * gnu/local.mk (GNU_SYSTEM_MODULES): Unregister deleted file. * po/packages/POTFILES.in: Unregister deleted file. * gnu/packages/{audio, avr, bioinformatics, busybox, cdrom, ci, compression, docbook, documentation, fonts, fpga, game-development, games, gl, gnome, gnuzilla, graphics, guile, haskell, image, java, kodi, ldc, libreoffice, markup, maths, mc, monitoring, music, php, pretty-print, python, scheme, smalltalk, statistics, synergy, tex, textutils, video, web-browsers, xml, zip}.scm, guix/build-system/{ant, font}.scm, guix/{download, packages}.scm: Adapt module import. --- guix/build-system/ant.scm | 2 +- guix/build-system/font.scm | 2 +- guix/download.scm | 2 +- guix/packages.scm | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm index 228b4e60d2..e0870a605c 100644 --- a/guix/build-system/ant.scm +++ b/guix/build-system/ant.scm @@ -58,7 +58,7 @@ (define (default-zip) "Return the default ZIP package." ;; Lazily resolve the binding to avoid a circular dependency. - (let ((zip-mod (resolve-interface '(gnu packages zip)))) + (let ((zip-mod (resolve-interface '(gnu packages compression)))) (module-ref zip-mod 'zip))) (define* (lower name diff --git a/guix/build-system/font.scm b/guix/build-system/font.scm index f448c302c2..d40a4985f8 100644 --- a/guix/build-system/font.scm +++ b/guix/build-system/font.scm @@ -56,13 +56,13 @@ '()) ,@inputs ,(list "tar" (module-ref (resolve-interface '(gnu packages base)) 'tar)) - ,(list "unzip" (module-ref (resolve-interface '(gnu packages zip)) 'unzip)) ,@(let ((compression (resolve-interface '(gnu packages compression)))) (map (match-lambda ((name package) (list name (module-ref compression package)))) `(("gzip" gzip) ("bzip2" bzip2) + ("unzip" unzip) ("xz" xz)))))) (build-inputs native-inputs) (outputs outputs) diff --git a/guix/download.scm b/guix/download.scm index bed1f502cf..c1da515477 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -528,7 +528,7 @@ own. This helper makes it easier to deal with \"zip bombs\"." (_ (basename url)))) (define unzip - (module-ref (resolve-interface '(gnu packages zip)) 'unzip)) + (module-ref (resolve-interface '(gnu packages compression)) 'unzip)) (mlet %store-monad ((drv (url-fetch url hash-algo hash (string-append "zipbomb-" diff --git a/guix/packages.scm b/guix/packages.scm index 76aa43e7d3..464fc433b2 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -401,7 +401,7 @@ object." ("bzip2" ,(ref '(gnu packages compression) 'bzip2)) ("gzip" ,(ref '(gnu packages compression) 'gzip)) ("lzip" ,(ref '(gnu packages compression) 'lzip)) - ("unzip" ,(ref '(gnu packages zip) 'unzip)) + ("unzip" ,(ref '(gnu packages compression) 'unzip)) ("patch" ,(ref '(gnu packages base) 'patch)) ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales))))) -- cgit v1.2.3 From 55b4715fd4c03e46501f123c5c9bc6072edf12a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Jun 2017 14:01:12 +0200 Subject: profiles: Represent propagated inputs as manifest entries. * guix/profiles.scm (package->manifest-entry): Turn DEPS into a list of manifest entries. (manifest->gexp)[entry->gexp]: Call 'entry->gexp' on DEPS. Bump version to 3. (sexp->manifest)[infer-dependency]: New procedure. Use it for versions 1 and 2. Parse version 3. (manifest-inputs)[entry->gexp]: New procedure. Adjust to 'dependencies' being a list of . * tests/profiles.scm ("packages->manifest, propagated inputs") ("read-manifest"): New fields. --- guix/profiles.scm | 73 +++++++++++++++++++++++++++++++++++++++--------------- tests/profiles.scm | 36 +++++++++++++++++++++++++++ 2 files changed, 89 insertions(+), 20 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 6733f105e3..a66add3e07 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -154,7 +154,7 @@ (output manifest-entry-output ; string (default "out")) (item manifest-entry-item) ; package | store path - (dependencies manifest-entry-dependencies ; (store path | package)* + (dependencies manifest-entry-dependencies ; * (default '())) (search-paths manifest-entry-search-paths ; search-path-specification* (default '()))) @@ -179,10 +179,10 @@ "Return a manifest entry for the OUTPUT of package PACKAGE." (let ((deps (map (match-lambda ((label package) - (gexp-input package)) + (package->manifest-entry package)) ((label package output) - (gexp-input package output))) - (package-transitive-propagated-inputs package)))) + (package->manifest-entry package output))) + (package-propagated-inputs package)))) (manifest-entry (name (package-name package)) (version (package-version package)) @@ -210,20 +210,20 @@ denoting a specific output of a package." (($ name version output (? string? path) (deps ...) (search-paths ...)) #~(#$name #$version #$output #$path - (propagated-inputs #$deps) + (propagated-inputs #$(map entry->gexp deps)) (search-paths #$(map search-path-specification->sexp search-paths)))) (($ name version output (? package? package) (deps ...) (search-paths ...)) #~(#$name #$version #$output (ungexp package (or output "out")) - (propagated-inputs #$deps) + (propagated-inputs #$(map entry->gexp deps)) (search-paths #$(map search-path-specification->sexp search-paths)))))) (match manifest (($ (entries ...)) - #~(manifest (version 2) + #~(manifest (version 3) (packages #$(map entry->gexp entries)))))) (define (find-package name version) @@ -254,17 +254,27 @@ procedure is here for backward-compatibility and will eventually vanish." (package-native-search-paths package) '()))) + (define (infer-dependency item) + ;; Return a for ITEM. + (let-values (((name version) + (package-name->name+version + (store-path-package-name item)))) + (manifest-entry + (name name) + (version version) + (item item)))) + (match sexp (('manifest ('version 0) ('packages ((name version output path) ...))) (manifest (map (lambda (name version output path) (manifest-entry - (name name) - (version version) - (output output) - (item path) - (search-paths (infer-search-paths name version)))) + (name name) + (version version) + (output output) + (item path) + (search-paths (infer-search-paths name version)))) name version output path))) ;; Version 1 adds a list of propagated inputs to the @@ -286,7 +296,7 @@ procedure is here for backward-compatibility and will eventually vanish." (version version) (output output) (item path) - (dependencies deps) + (dependencies (map infer-dependency deps)) (search-paths (infer-search-paths name version))))) name version output path deps))) @@ -304,10 +314,30 @@ procedure is here for backward-compatibility and will eventually vanish." (version version) (output output) (item path) - (dependencies deps) + (dependencies (map infer-dependency deps)) (search-paths (map sexp->search-path-specification search-paths)))) name version output path deps search-paths))) + + ;; Version 3 represents DEPS as full-blown manifest entries. + (('manifest ('version 3 minor-version ...) + ('packages (entries ...))) + (letrec ((sexp->manifest-entry + (match-lambda + ((name version output path + ('propagated-inputs deps) + ('search-paths search-paths) + extra-stuff ...) + (manifest-entry + (name name) + (version version) + (output output) + (item path) + (dependencies (map sexp->manifest-entry deps)) + (search-paths (map sexp->search-path-specification + search-paths))))))) + + (manifest (map sexp->manifest-entry entries)))) (_ (raise (condition (&message (message "unsupported manifest format"))))))) @@ -471,12 +501,15 @@ replace it." (define (manifest-inputs manifest) "Return a list of objects for MANIFEST." - (append-map (match-lambda - (($ name version output thing deps) - ;; THING may be a package or a file name. In the latter case, - ;; assume it's already valid. Ditto for DEPS. - (cons (gexp-input thing output) deps))) - (manifest-entries manifest))) + (define entry->input + (match-lambda + (($ name version output thing deps) + ;; THING may be a package or a file name. In the latter case, assume + ;; it's already valid. + (cons (gexp-input thing output) + (append-map entry->input deps))))) + + (append-map entry->input (manifest-entries manifest))) (define* (manifest-lookup-package manifest name #:optional version) "Return as a monadic value the first package or store path referenced by diff --git a/tests/profiles.scm b/tests/profiles.scm index 093422792f..e8b1bb832c 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -288,6 +288,42 @@ (manifest-entry-search-paths (package->manifest-entry mpl))))) +(test-equal "packages->manifest, propagated inputs" + (map (match-lambda + ((label package) + (list (package-name package) (package-version package) + package))) + (package-propagated-inputs packages:guile-2.2)) + (map (lambda (entry) + (list (manifest-entry-name entry) + (manifest-entry-version entry) + (manifest-entry-item entry))) + (manifest-entry-dependencies + (package->manifest-entry packages:guile-2.2)))) + +(test-assertm "read-manifest" + (mlet* %store-monad ((manifest -> (packages->manifest + (list (package + (inherit %bootstrap-guile) + (native-search-paths + (package-native-search-paths + packages:guile-2.0)))))) + (drv (profile-derivation manifest + #:hooks '() + #:locales? #f)) + (out -> (derivation->output-path drv))) + (define (entry->sexp entry) + (list (manifest-entry-name entry) + (manifest-entry-version entry) + (manifest-entry-search-paths entry) + (manifest-entry-dependencies entry))) + + (mbegin %store-monad + (built-derivations (list drv)) + (let ((manifest2 (profile-manifest out))) + (return (equal? (map entry->sexp (manifest-entries manifest)) + (map entry->sexp (manifest-entries manifest2)))))))) + (test-assertm "etc/profile" ;; Make sure we get an 'etc/profile' file that at least defines $PATH. (mlet* %store-monad -- cgit v1.2.3 From b3a00885c0a420692ccc4c227252bb44619399d5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Jun 2017 15:29:50 +0200 Subject: profiles: Manifest entries keep a reference to their parent entry. * guix/profiles.scm ()[parent]: New field. (package->manifest-entry): Add #:parent parameter. Fill out the 'parent' field of ; pass #:parent in recursive calls. * guix/profiles.scm (sexp->manifest)[sexp->manifest-entry]: New procedure. Use it for version 3. * tests/profiles.scm ("manifest-entry-parent"): New procedure. ("read-manifest")[entry->sexp]: Add 'manifest-entry-parent' to the result. --- guix/profiles.scm | 120 ++++++++++++++++++++++++++++++++--------------------- tests/profiles.scm | 12 +++++- 2 files changed, 83 insertions(+), 49 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index a66add3e07..c85d7ef5cb 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -68,6 +68,7 @@ manifest-entry-item manifest-entry-dependencies manifest-entry-search-paths + manifest-entry-parent manifest-pattern manifest-pattern? @@ -157,7 +158,9 @@ (dependencies manifest-entry-dependencies ; * (default '())) (search-paths manifest-entry-search-paths ; search-path-specification* - (default '()))) + (default '())) + (parent manifest-entry-parent ; promise (#f | ) + (default (delay #f)))) (define-record-type* manifest-pattern make-manifest-pattern @@ -175,21 +178,28 @@ (call-with-input-file file read-manifest) (manifest '())))) -(define* (package->manifest-entry package #:optional (output "out")) +(define* (package->manifest-entry package #:optional (output "out") + #:key (parent (delay #f))) "Return a manifest entry for the OUTPUT of package PACKAGE." - (let ((deps (map (match-lambda - ((label package) - (package->manifest-entry package)) - ((label package output) - (package->manifest-entry package output))) - (package-propagated-inputs package)))) - (manifest-entry - (name (package-name package)) - (version (package-version package)) - (output output) - (item package) - (dependencies (delete-duplicates deps)) - (search-paths (package-transitive-native-search-paths package))))) + ;; For each dependency, keep a promise pointing to its "parent" entry. + (letrec* ((deps (map (match-lambda + ((label package) + (package->manifest-entry package + #:parent (delay entry))) + ((label package output) + (package->manifest-entry package output + #:parent (delay entry)))) + (package-propagated-inputs package))) + (entry (manifest-entry + (name (package-name package)) + (version (package-version package)) + (output output) + (item package) + (dependencies (delete-duplicates deps)) + (search-paths + (package-transitive-native-search-paths package)) + (parent parent)))) + entry)) (define (packages->manifest packages) "Return a list of manifest entries, one for each item listed in PACKAGES. @@ -254,7 +264,7 @@ procedure is here for backward-compatibility and will eventually vanish." (package-native-search-paths package) '()))) - (define (infer-dependency item) + (define (infer-dependency item parent) ;; Return a for ITEM. (let-values (((name version) (package-name->name+version @@ -262,7 +272,28 @@ procedure is here for backward-compatibility and will eventually vanish." (manifest-entry (name name) (version version) - (item item)))) + (item item) + (parent parent)))) + + (define* (sexp->manifest-entry sexp #:optional (parent (delay #f))) + (match sexp + ((name version output path + ('propagated-inputs deps) + ('search-paths search-paths) + extra-stuff ...) + ;; For each of DEPS, keep a promise pointing to ENTRY. + (letrec* ((deps* (map (cut sexp->manifest-entry <> (delay entry)) + deps)) + (entry (manifest-entry + (name name) + (version version) + (output output) + (item path) + (dependencies deps*) + (search-paths (map sexp->search-path-specification + search-paths)) + (parent parent)))) + entry)))) (match sexp (('manifest ('version 0) @@ -291,13 +322,17 @@ procedure is here for backward-compatibility and will eventually vanish." directories) ((directories ...) directories)))) - (manifest-entry - (name name) - (version version) - (output output) - (item path) - (dependencies (map infer-dependency deps)) - (search-paths (infer-search-paths name version))))) + (letrec* ((deps* (map (cute infer-dependency <> (delay entry)) + deps)) + (entry (manifest-entry + (name name) + (version version) + (output output) + (item path) + (dependencies deps*) + (search-paths + (infer-search-paths name version))))) + entry))) name version output path deps))) ;; Version 2 adds search paths and is slightly more verbose. @@ -309,35 +344,24 @@ procedure is here for backward-compatibility and will eventually vanish." ...))) (manifest (map (lambda (name version output path deps search-paths) - (manifest-entry - (name name) - (version version) - (output output) - (item path) - (dependencies (map infer-dependency deps)) - (search-paths (map sexp->search-path-specification - search-paths)))) + (letrec* ((deps* (map (cute infer-dependency <> (delay entry)) + deps)) + (entry (manifest-entry + (name name) + (version version) + (output output) + (item path) + (dependencies deps*) + (search-paths + (map sexp->search-path-specification + search-paths))))) + entry)) name version output path deps search-paths))) ;; Version 3 represents DEPS as full-blown manifest entries. (('manifest ('version 3 minor-version ...) ('packages (entries ...))) - (letrec ((sexp->manifest-entry - (match-lambda - ((name version output path - ('propagated-inputs deps) - ('search-paths search-paths) - extra-stuff ...) - (manifest-entry - (name name) - (version version) - (output output) - (item path) - (dependencies (map sexp->manifest-entry deps)) - (search-paths (map sexp->search-path-specification - search-paths))))))) - - (manifest (map sexp->manifest-entry entries)))) + (manifest (map sexp->manifest-entry entries))) (_ (raise (condition (&message (message "unsupported manifest format"))))))) diff --git a/tests/profiles.scm b/tests/profiles.scm index e8b1bb832c..94759c05ef 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -301,6 +301,15 @@ (manifest-entry-dependencies (package->manifest-entry packages:guile-2.2)))) +(test-assert "manifest-entry-parent" + (let ((entry (package->manifest-entry packages:guile-2.2))) + (match (manifest-entry-dependencies entry) + ((dependencies ..1) + (and (every (lambda (parent) + (eq? entry (force parent))) + (map manifest-entry-parent dependencies)) + (not (force (manifest-entry-parent entry)))))))) + (test-assertm "read-manifest" (mlet* %store-monad ((manifest -> (packages->manifest (list (package @@ -316,7 +325,8 @@ (list (manifest-entry-name entry) (manifest-entry-version entry) (manifest-entry-search-paths entry) - (manifest-entry-dependencies entry))) + (manifest-entry-dependencies entry) + (force (manifest-entry-parent entry)))) (mbegin %store-monad (built-derivations (list drv)) -- cgit v1.2.3 From 81e3485c0d012e29d4e551107fc31c0da89b0006 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 7 Jun 2017 11:15:29 +0200 Subject: guix package: Always upgrade packages that have propagated inputs. * guix/scripts/package.scm (transaction-upgrade-entry): Always upgrade packages that have propagated inputs. --- guix/scripts/package.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index a6bfb03ae4..5e19df5e43 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -312,7 +312,10 @@ of relevance scores." ((=) (let ((candidate-path (derivation->output-path (package-derivation (%store) pkg)))) - (if (string=? path candidate-path) + ;; XXX: When there are propagated inputs, assume we need to + ;; upgrade the whole entry. + (if (and (string=? path candidate-path) + (null? (package-propagated-inputs pkg))) transaction (manifest-transaction-install-entry (package->manifest-entry pkg output) -- cgit v1.2.3 From a654dc4bcf7c8e205bdefa1a1d5f23444dd22778 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 7 Jun 2017 09:51:55 +0200 Subject: profiles: Catch and report collisions in the profile. * guix/profiles.scm (&profile-collision-error): New error condition. (manifest-transitive-entries, manifest-entry-lookup, lower-manifest-entry) (check-for-collisions): New procedures. (profile-derivation): Add call to 'check-for-collisions'. * guix/ui.scm (call-with-error-handling): Handle '&profile-collision-error'. * tests/profiles.scm ("collision", "collision of propagated inputs") ("no collision"): New tests. --- guix/profiles.scm | 113 ++++++++++++++++++++++++++++++++++++++++++++++++----- guix/ui.scm | 27 +++++++++++++ tests/profiles.scm | 66 +++++++++++++++++++++++++++++++ 3 files changed, 197 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index c85d7ef5cb..9858ec7b35 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -35,6 +35,8 @@ #:use-module (guix gexp) #:use-module (guix monads) #:use-module (guix store) + #:use-module (guix sets) + #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 ftw) @@ -51,6 +53,10 @@ profile-error-profile &profile-not-found-error profile-not-found-error? + &profile-collistion-error + profile-collision-error? + profile-collision-error-entry + profile-collision-error-conflict &missing-generation-error missing-generation-error? missing-generation-error-generation @@ -58,6 +64,7 @@ manifest make-manifest manifest? manifest-entries + manifest-transitive-entries ; FIXME: eventually make it internal manifest-entry @@ -130,6 +137,11 @@ (define-condition-type &profile-not-found-error &profile-error profile-not-found-error?) +(define-condition-type &profile-collision-error &error + profile-collision-error? + (entry profile-collision-error-entry) ; + (conflict profile-collision-error-conflict)) ; + (define-condition-type &missing-generation-error &profile-error missing-generation-error? (generation missing-generation-error-generation)) @@ -147,6 +159,23 @@ ;; Convenient alias, to avoid name clashes. (define make-manifest manifest) +(define (manifest-transitive-entries manifest) + "Return the entries of MANIFEST along with their propagated inputs, +recursively." + (let loop ((entries (manifest-entries manifest)) + (result '()) + (visited (set))) ;compare with 'equal?' + (match entries + (() + (reverse result)) + ((head . tail) + (if (set-contains? visited head) + (loop tail result visited) + (loop (append (manifest-entry-dependencies head) + tail) + (cons head result) + (set-insert head visited))))))) + (define-record-type* manifest-entry make-manifest-entry manifest-entry? @@ -178,6 +207,70 @@ (call-with-input-file file read-manifest) (manifest '())))) +(define (manifest-entry-lookup manifest) + "Return a lookup procedure for the entries of MANIFEST. The lookup +procedure takes two arguments: the entry name and output." + (define mapping + (let loop ((entries (manifest-entries manifest)) + (mapping vlist-null)) + (fold (lambda (entry result) + (vhash-cons (cons (manifest-entry-name entry) + (manifest-entry-output entry)) + entry + (loop (manifest-entry-dependencies entry) + result))) + mapping + entries))) + + (lambda (name output) + (match (vhash-assoc (cons name output) mapping) + ((_ . entry) entry) + (#f #f)))) + +(define* (lower-manifest-entry entry system #:key target) + "Lower ENTRY for SYSTEM and TARGET such that its 'item' field is a store +file name." + (let ((item (manifest-entry-item entry))) + (if (string? item) + (with-monad %store-monad + (return entry)) + (mlet %store-monad ((drv (lower-object item system + #:target target)) + (output -> (manifest-entry-output entry))) + (return (manifest-entry + (inherit entry) + (item (derivation->output-path drv output)))))))) + +(define* (check-for-collisions manifest system #:key target) + "Check whether the entries of MANIFEST conflict with one another; raise a +'&profile-collision-error' when a conflict is encountered." + (define lookup + (manifest-entry-lookup manifest)) + + (with-monad %store-monad + (foldm %store-monad + (lambda (entry result) + (match (lookup (manifest-entry-name entry) + (manifest-entry-output entry)) + ((? manifest-entry? second) ;potential conflict + (mlet %store-monad ((first (lower-manifest-entry entry system + #:target + target)) + (second (lower-manifest-entry second system + #:target + target))) + (if (string=? (manifest-entry-item first) + (manifest-entry-item second)) + (return result) + (raise (condition + (&profile-collision-error + (entry first) + (conflict second))))))) + (#f ;no conflict + (return result)))) + #t + (manifest-transitive-entries manifest)))) + (define* (package->manifest-entry package #:optional (output "out") #:key (parent (delay #f))) "Return a manifest entry for the OUTPUT of package PACKAGE." @@ -1116,15 +1209,17 @@ a dependency on the 'glibc-utf8-locales' package. When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST are cross-built for TARGET." - (mlet %store-monad ((system (if system - (return system) - (current-system))) - (extras (if (null? (manifest-entries manifest)) - (return '()) - (sequence %store-monad - (map (lambda (hook) - (hook manifest)) - hooks))))) + (mlet* %store-monad ((system (if system + (return system) + (current-system))) + (ok? (check-for-collisions manifest system + #:target target)) + (extras (if (null? (manifest-entries manifest)) + (return '()) + (sequence %store-monad + (map (lambda (hook) + (hook manifest)) + hooks))))) (define inputs (append (filter-map (lambda (drv) (and (derivation? drv) diff --git a/guix/ui.scm b/guix/ui.scm index 889c9d0228..c141880316 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -476,6 +476,33 @@ interpreted." (leave (G_ "generation ~a of profile '~a' does not exist~%") (missing-generation-error-generation c) (profile-error-profile c))) + ((profile-collision-error? c) + (let ((entry (profile-collision-error-entry c)) + (conflict (profile-collision-error-conflict c))) + (define (report-parent-entries entry) + (let ((parent (force (manifest-entry-parent entry)))) + (when (manifest-entry? parent) + (report-error (G_ " ... propagated from ~a@~a~%") + (manifest-entry-name parent) + (manifest-entry-version parent)) + (report-parent-entries parent)))) + + (report-error (G_ "profile contains conflicting entries for ~a:~a~%") + (manifest-entry-name entry) + (manifest-entry-output entry)) + (report-error (G_ " first entry: ~a@~a:~a ~a~%") + (manifest-entry-name entry) + (manifest-entry-version entry) + (manifest-entry-output entry) + (manifest-entry-item entry)) + (report-parent-entries entry) + (report-error (G_ " second entry: ~a@~a:~a ~a~%") + (manifest-entry-name conflict) + (manifest-entry-version conflict) + (manifest-entry-output conflict) + (manifest-entry-item conflict)) + (report-parent-entries conflict) + (exit 1))) ((nar-error? c) (let ((file (nar-error-file c)) (port (nar-error-port c))) diff --git a/tests/profiles.scm b/tests/profiles.scm index 94759c05ef..f731807e8c 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -35,6 +35,7 @@ #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-64)) ;; Test the (guix profiles) module. @@ -334,6 +335,71 @@ (return (equal? (map entry->sexp (manifest-entries manifest)) (map entry->sexp (manifest-entries manifest2)))))))) +(test-equal "collision" + '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42")) + (guard (c ((profile-collision-error? c) + (let ((entry1 (profile-collision-error-entry c)) + (entry2 (profile-collision-error-conflict c))) + (list (list (manifest-entry-name entry1) + (manifest-entry-version entry1)) + (list (manifest-entry-name entry2) + (manifest-entry-version entry2)))))) + (run-with-store %store + (mlet* %store-monad ((p0 -> (package + (inherit %bootstrap-guile) + (version "42"))) + (p1 -> (dummy-package "p1" + (propagated-inputs `(("p0" ,p0))))) + (manifest -> (packages->manifest + (list %bootstrap-guile p1))) + (drv (profile-derivation manifest + #:hooks '() + #:locales? #f))) + (return #f))))) + +(test-equal "collision of propagated inputs" + '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42")) + (guard (c ((profile-collision-error? c) + (let ((entry1 (profile-collision-error-entry c)) + (entry2 (profile-collision-error-conflict c))) + (list (list (manifest-entry-name entry1) + (manifest-entry-version entry1)) + (list (manifest-entry-name entry2) + (manifest-entry-version entry2)))))) + (run-with-store %store + (mlet* %store-monad ((p0 -> (package + (inherit %bootstrap-guile) + (version "42"))) + (p1 -> (dummy-package "p1" + (propagated-inputs + `(("guile" ,%bootstrap-guile))))) + (p2 -> (dummy-package "p2" + (propagated-inputs + `(("guile" ,p0))))) + (manifest -> (packages->manifest (list p1 p2))) + (drv (profile-derivation manifest + #:hooks '() + #:locales? #f))) + (return #f))))) + +(test-assertm "no collision" + ;; Here we have an entry that is "lowered" (its 'item' field is a store file + ;; name) and another entry (its 'item' field is a package) that is + ;; equivalent. + (mlet* %store-monad ((p -> (dummy-package "p" + (propagated-inputs + `(("guile" ,%bootstrap-guile))))) + (guile (package->derivation %bootstrap-guile)) + (entry -> (manifest-entry + (inherit (package->manifest-entry + %bootstrap-guile)) + (item (derivation->output-path guile)))) + (manifest -> (manifest + (list entry + (package->manifest-entry p)))) + (drv (profile-derivation manifest))) + (return (->bool drv)))) + (test-assertm "etc/profile" ;; Make sure we get an 'etc/profile' file that at least defines $PATH. (mlet* %store-monad -- cgit v1.2.3 From 8c9e90debf1e7af3da167e34dcdc405b16f339e7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 21 Jun 2017 10:57:10 +0200 Subject: guix package: '--search-paths' shows search paths from propagated inputs. * guix/scripts/package.scm (process-query) <'search-paths>: Use 'manifest-transitive-entries' instead of 'manifest-entries'. --- guix/scripts/package.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5e19df5e43..4834da9271 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -789,7 +789,8 @@ processed, #f otherwise." (('search-paths kind) (let* ((manifests (map profile-manifest profiles)) - (entries (append-map manifest-entries manifests)) + (entries (append-map manifest-transitive-entries + manifests)) (profiles (map user-friendly-profile profiles)) (settings (search-path-environment-variables entries profiles (const #f) -- cgit v1.2.3 From 2e2b5ad7bbf6cf693519e51500ad1cc7dce93ef5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 21 Jun 2017 11:58:39 +0200 Subject: profiles: Move 'manifest-entry-dependencies' user after definition. Reported by Efraim Flashner. * guix/profiles.scm (manifest-transitive-entries): Move after definition. --- guix/profiles.scm | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 9858ec7b35..0c70975f7e 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -159,23 +159,6 @@ ;; Convenient alias, to avoid name clashes. (define make-manifest manifest) -(define (manifest-transitive-entries manifest) - "Return the entries of MANIFEST along with their propagated inputs, -recursively." - (let loop ((entries (manifest-entries manifest)) - (result '()) - (visited (set))) ;compare with 'equal?' - (match entries - (() - (reverse result)) - ((head . tail) - (if (set-contains? visited head) - (loop tail result visited) - (loop (append (manifest-entry-dependencies head) - tail) - (cons head result) - (set-insert head visited))))))) - (define-record-type* manifest-entry make-manifest-entry manifest-entry? @@ -200,6 +183,23 @@ recursively." (output manifest-pattern-output ; string | #f (default "out"))) +(define (manifest-transitive-entries manifest) + "Return the entries of MANIFEST along with their propagated inputs, +recursively." + (let loop ((entries (manifest-entries manifest)) + (result '()) + (visited (set))) ;compare with 'equal?' + (match entries + (() + (reverse result)) + ((head . tail) + (if (set-contains? visited head) + (loop tail result visited) + (loop (append (manifest-entry-dependencies head) + tail) + (cons head result) + (set-insert head visited))))))) + (define (profile-manifest profile) "Return the PROFILE's manifest." (let ((file (string-append profile "/manifest"))) -- cgit v1.2.3 From afd06f605bf88a796acefc7ed598b43879346a6b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 21 Jun 2017 16:50:59 +0200 Subject: environment: Disable profile collision checks. Reported by Efraim Flashner. This is a followup to a654dc4bcf7c8e205bdefa1a1d5f23444dd22778. * guix/profiles.scm (profile-derivation): Add #:allow-collisions? and honor it. * guix/scripts/environment.scm (inputs->profile-derivation): Pass #:allow-collisions? #f to 'profile-derivation'. * tests/guix-environment.sh: Test "guix environment guix". --- guix/profiles.scm | 10 ++++++++-- guix/scripts/environment.scm | 7 +++++++ tests/guix-environment.sh | 4 ++++ 3 files changed, 19 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 0c70975f7e..dcb5186c7a 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1199,10 +1199,14 @@ the entries in MANIFEST." #:key (hooks %default-profile-hooks) (locales? #t) + (allow-collisions? #f) system target) "Return a derivation that builds a profile (aka. 'user environment') with the given MANIFEST. The profile includes additional derivations returned by the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc. +Unless ALLOW-COLLISIONS? is true, a '&profile-collision-error' is raised if +entries in MANIFEST collide (for instance if there are two same-name packages +with a different version number.) When LOCALES? is true, the build is performed under a UTF-8 locale; this adds a dependency on the 'glibc-utf8-locales' package. @@ -1212,8 +1216,10 @@ are cross-built for TARGET." (mlet* %store-monad ((system (if system (return system) (current-system))) - (ok? (check-for-collisions manifest system - #:target target)) + (ok? (if allow-collisions? + (return #t) + (check-for-collisions manifest system + #:target target))) (extras (if (null? (manifest-entries manifest)) (return '()) (sequence %store-monad diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index af69e2b730..0abc509a35 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -323,6 +323,13 @@ BOOTSTRAP? specifies whether to use the bootstrap Guile to build the profile." (profile-derivation (packages->manifest inputs) #:system system + + ;; Packages can have conflicting inputs, or explicit + ;; inputs that conflict with implicit inputs (e.g., gcc, + ;; gzip, etc.). Thus, do not error out when we + ;; encounter collision. + #:allow-collisions? #t + #:hooks (if bootstrap? '() %default-profile-hooks) diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index 9115949123..bf5ca17fa5 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -105,6 +105,10 @@ else test $? = 42 fi +# Make sure we can build the environment of 'guix'. There may be collisions +# in its profile (e.g., for 'gzip'), but we have to accept them. +guix environment guix --bootstrap -n + if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null then # Compute the build environment for the initial GNU Make. -- cgit v1.2.3 From 7ae97a4c3f241e6d6e9b8bc6d13ff8d4d9ded9bd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 21 Jun 2017 23:00:08 +0200 Subject: store: Pass a socket type hint to 'getaddrinfo'. * guix/store.scm (open-inet-socket): Pass hints in the 'getaddrinfo' call. --- guix/store.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index b584caa073..9b4c65532e 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -399,7 +399,9 @@ (if (number? port) (number->string port) port) (if (number? port) (logior AI_ADDRCONFIG AI_NUMERICSERV) - AI_ADDRCONFIG))) + AI_ADDRCONFIG) + 0 ;any address family + SOCK_STREAM)) ;TCP only (let loop ((addresses addresses)) (match addresses -- cgit v1.2.3 From 5df1395a8d4bb83e002e1aab5d930edd2b49d27e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 19 Jun 2017 17:50:28 +0200 Subject: store: Define a default port for TCP connections. * guix/store.scm (%default-guix-port): New variable. (connect-to-daemon)[connect]: Use it when (uri-port uri) is #f. * doc/guix.texi (The Store): Mention the default port number. --- doc/guix.texi | 4 ++-- guix/store.scm | 12 ++++++------ 2 files changed, 8 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 87147802b3..ee9f80ef4d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3770,8 +3770,8 @@ These are for Unix-domain sockets. @item guix These URIs denote connections over TCP/IP, without encryption nor -authentication of the remote host. The URI must always specify both the -host name and port number: +authentication of the remote host. The URI must specify the host name +and optionally a port number (by default port 44146 is used): @example guix://master.guix.example.org:1234 diff --git a/guix/store.scm b/guix/store.scm index 9b4c65532e..d1a4c67ae8 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -383,6 +383,10 @@ (connect s a) s))) +(define %default-guix-port + ;; Default port when connecting to a daemon over TCP/IP. + 44146) + (define (open-inet-socket host port) "Connect to the Unix-domain socket at HOST:PORT and return it. Raise a '&nix-connection-error' upon error." @@ -446,12 +450,8 @@ name." (open-unix-domain-socket (uri-path uri)))) ('guix (lambda (_) - (unless (uri-port uri) - (raise (condition (&nix-connection-error - (file (uri->string uri)) - (errno EBADR))))) ;bah! - - (open-inet-socket (uri-host uri) (uri-port uri)))) + (open-inet-socket (uri-host uri) + (or (uri-port uri) %default-guix-port)))) ((? symbol? scheme) ;; Try to dynamically load a module for SCHEME. ;; XXX: Errors are swallowed. -- cgit v1.2.3 From 4c228f9e54180ffe733957fee586fc7179f64e28 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 24 Jun 2017 18:58:44 +0200 Subject: refresh: Be more verbose when passed an explicit package list. * guix/scripts/refresh.scm (check-for-package-update): Use 'version-compare' instead of 'version>?'. When WARN? is true, print something for the '=' and '<' cases. --- guix/scripts/refresh.scm | 35 ++++++++++++++++++++++++++--------- 1 file changed, 26 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index dd93e7d3e7..5add64d8e8 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -253,15 +253,32 @@ downloaded and authenticated; not updating~%") WARN? is true and no updater exists for PACKAGE, print a warning." (match (package-latest-release package updaters) ((? upstream-source? source) - (when (version>? (upstream-source-version source) - (package-version package)) - (let ((loc (or (package-field-location package 'version) - (package-location package)))) - (format (current-error-port) - (G_ "~a: ~a would be upgraded from ~a to ~a~%") - (location->string loc) - (package-name package) (package-version package) - (upstream-source-version source))))) + (let ((loc (or (package-field-location package 'version) + (package-location package)))) + (case (version-compare (upstream-source-version source) + (package-version package)) + ((>) + (format (current-error-port) + (G_ "~a: ~a would be upgraded from ~a to ~a~%") + (location->string loc) + (package-name package) (package-version package) + (upstream-source-version source))) + ((=) + (when warn? + (format (current-error-port) + (G_ "~a: info: ~a is already the latest version of ~a~%") + (location->string loc) + (package-version package) + (package-name package)))) + (else + (when warn? + (format (current-error-port) + (G_ "~a: warning: ~a is greater than \ +the latest known version of ~a (~a)~%") + (location->string loc) + (package-version package) + (package-name package) + (upstream-source-version source))))))) (#f (when warn? (warn-no-updater package))))) -- cgit v1.2.3 From a1b46bdc069e6e3bbc5b171fafbc40213611ff1f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 25 Jun 2017 22:16:58 +0200 Subject: guix package: Warn about packages that no longer exist. Fixes . Reported by Mark H Weaver . * guix/scripts/package.scm (transaction-upgrade-entry): Add call to 'warning' when NAME cannot be found in the package set. --- guix/scripts/package.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4834da9271..1f835ca5a5 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -321,6 +321,7 @@ of relevance scores." (package->manifest-entry pkg output) transaction)))))))) (#f + (warning (G_ "package '~a' no longer exists~%") name) transaction))))) -- cgit v1.2.3