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.
This commit is contained in:
Ludovic Courtès
parent
e7e04396c0
commit
89e2288751
@ -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)))))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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>.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user