summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2022-07-08 12:26:50 +0200
committerLudovic Courtès <ludo@gnu.org>2022-07-08 23:58:11 +0200
commit89e22887510ba5d546a4d7e391462e648942a7b6 (patch)
treecee8ae3249134f41a04c6f91d5cbca31651396a4
parente7e04396c0e91569bf493e1352d6539babc15327 (diff)
profiles: Support the creation of profiles with version 3 manifests.
* guix/profiles.scm (%manifest-format-version): New variable. (manifest->gexp): Add optional 'format-version' parameter. [optional, entry->gexp]: Honor it. (profile-derivation): Add #:format-version parameter and honor it. (<profile>)[format-version]: New field. (profile-compiler): Honor it. * guix/build/profiles.scm (manifest-sexp->inputs+search-paths): Support both versions 3 and 4. Remove unused 'properties' variable. * tests/profiles.scm ("profile-derivation format version 3"): New test.
-rw-r--r--guix/build/profiles.scm6
-rw-r--r--guix/profiles.scm48
-rw-r--r--tests/profiles.scm28
3 files changed, 66 insertions, 16 deletions
diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm
index 2ab76bde74..0c92f222b4 100644
--- a/guix/build/profiles.scm
+++ b/guix/build/profiles.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017-2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -162,7 +162,7 @@ search path specifications."
(begin body ...))))
(match manifest ;this must match 'manifest->gexp'
- (('manifest ('version 4)
+ (('manifest ('version (or 3 4))
('packages (entries ...)))
(let loop ((entries entries)
(inputs '())
@@ -170,7 +170,7 @@ search path specifications."
(match entries
(((name version output item fields ...) . rest)
(let ((paths search-paths))
- (let-fields fields (propagated-inputs search-paths properties)
+ (let-fields fields (propagated-inputs search-paths)
(loop (append rest propagated-inputs) ;breadth-first traversal
(cons item inputs)
(append search-paths paths)))))
diff --git a/guix/profiles.scm b/guix/profiles.scm
index a21cc432dc..d1dfa13e98 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -452,12 +452,23 @@ denoting a specific output of a package."
packages)
manifest-entry=?)))
-(define (manifest->gexp manifest)
- "Return a representation of MANIFEST as a gexp."
+(define %manifest-format-version
+ ;; The current manifest format version.
+ 4)
+
+(define* (manifest->gexp manifest #:optional
+ (format-version %manifest-format-version))
+ "Return a representation in FORMAT-VERSION of MANIFEST as a gexp."
(define (optional name value)
- (if (null? value)
- #~()
- #~((#$name #$value))))
+ (match format-version
+ (4
+ (if (null? value)
+ #~()
+ #~((#$name #$value))))
+ (3
+ (match name
+ ('properties #~((#$name #$@value)))
+ (_ #~((#$name #$value)))))))
(define (entry->gexp entry)
;; Maintain in state monad a vhash of visited entries, indexed by their
@@ -467,10 +478,11 @@ denoting a specific output of a package."
;; the presence of propagated inputs, where we could otherwise end up
;; repeating large trees.
(mlet %state-monad ((visited (current-state)))
- (if (match (vhash-assq (manifest-entry-item entry) visited)
- ((_ . previous-entry)
- (manifest-entry=? previous-entry entry))
- (#f #f))
+ (if (and (= format-version 4)
+ (match (vhash-assq (manifest-entry-item entry) visited)
+ ((_ . previous-entry)
+ (manifest-entry=? previous-entry entry))
+ (#f #f)))
(return #~(repeated #$(manifest-entry-name entry)
#$(manifest-entry-version entry)
(ungexp (manifest-entry-item entry)
@@ -500,9 +512,14 @@ denoting a specific output of a package."
search-paths))
#$@(optional 'properties properties))))))))))
+ (unless (memq format-version '(3 4))
+ (raise (formatted-message
+ (G_ "cannot emit manifests formatted as version ~a")
+ format-version)))
+
(match manifest
(($ <manifest> (entries ...))
- #~(manifest (version 4)
+ #~(manifest (version #$format-version)
(packages #$(run-with-state
(mapm %state-monad entry->gexp entries)
vlist-null))))))
@@ -1883,6 +1900,7 @@ MANIFEST."
(allow-unsupported-packages? #f)
(allow-collisions? #f)
(relative-symlinks? #f)
+ (format-version %manifest-format-version)
system target)
"Return a derivation that builds a profile (aka. 'user environment') with
the given MANIFEST. The profile includes additional derivations returned by
@@ -1968,7 +1986,7 @@ are cross-built for TARGET."
#+(if locales? set-utf8-locale #t)
- (build-profile #$output '#$(manifest->gexp manifest)
+ (build-profile #$output '#$(manifest->gexp manifest format-version)
#:extra-inputs '#$extra-inputs
#:symlink #$(if relative-symlinks?
#~symlink-relative
@@ -2007,19 +2025,23 @@ are cross-built for TARGET."
(allow-collisions? profile-allow-collisions? ;Boolean
(default #f))
(relative-symlinks? profile-relative-symlinks? ;Boolean
- (default #f)))
+ (default #f))
+ (format-version profile-format-version ;integer
+ (default %manifest-format-version)))
(define-gexp-compiler (profile-compiler (profile <profile>) system target)
"Compile PROFILE to a derivation."
(match profile
(($ <profile> name manifest hooks
- locales? allow-collisions? relative-symlinks?)
+ locales? allow-collisions? relative-symlinks?
+ format-version)
(profile-derivation manifest
#:name name
#:hooks hooks
#:locales? locales?
#:allow-collisions? allow-collisions?
#:relative-symlinks? relative-symlinks?
+ #:format-version format-version
#:system system #:target target))))
(define* (profile-search-paths profile
diff --git a/tests/profiles.scm b/tests/profiles.scm
index f002dfc5e4..7bed946bf3 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -286,6 +286,34 @@
(string=? (dirname (readlink bindir))
(derivation->output-path guile))))))
+(test-assertm "profile-derivation format version 3"
+ ;; Make sure we can create and read a version 3 manifest.
+ (mlet* %store-monad
+ ((entry -> (package->manifest-entry %bootstrap-guile
+ #:properties '((answer . 42))))
+ (manifest -> (manifest (list entry)))
+ (drv1 (profile-derivation manifest
+ #:format-version 3 ;old version
+ #:hooks '()
+ #:locales? #f))
+ (drv2 (profile-derivation manifest
+ #:hooks '()
+ #:locales? #f))
+ (profile1 -> (derivation->output-path drv1))
+ (profile2 -> (derivation->output-path drv2))
+ (_ (built-derivations (list drv1 drv2))))
+ (return (let ((manifest1 (profile-manifest profile1))
+ (manifest2 (profile-manifest profile2)))
+ (match (manifest-entries manifest1)
+ ((entry1)
+ (match (manifest-entries manifest2)
+ ((entry2)
+ (and (manifest-entry=? entry1 entry2)
+ (equal? (manifest-entry-properties entry1)
+ '((answer . 42)))
+ (equal? (manifest-entry-properties entry2)
+ '((answer . 42))))))))))))
+
(test-assertm "profile-derivation, ordering & collisions"
;; ENTRY1 and ENTRY2 both provide 'bin/guile'--a collision. Make sure
;; ENTRY1 "wins" over ENTRY2. See <https://bugs.gnu.org/49102>.