kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

profiles: Support the creation of profiles with version 3 manifests.

Browse Source 
* 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 2022-07-08 12:26:50 +02:00
parent e7e04396c0
commit 89e2288751
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 66 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
guix/build/profiles.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -162,7 +162,7 @@ search path specifications."
(begin body ...)))) (begin body ...))))
(match manifest ;this must match 'manifest->gexp' (match manifest ;this must match 'manifest->gexp'
(('manifest ('version 4) (('manifest ('version (or 3 4))
('packages (entries ...))) ('packages (entries ...)))
(let loop ((entries entries) (let loop ((entries entries)
(inputs '()) (inputs '())
@ -170,7 +170,7 @@ search path specifications."
(match entries (match entries
(((name version output item fields ...) . rest) (((name version output item fields ...) . rest)
(let ((paths search-paths)) (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 (loop (append rest propagated-inputs) ;breadth-first traversal
(cons item inputs) (cons item inputs)
(append search-paths paths))))) (append search-paths paths)))))

38
guix/profiles.scm
View File

@ -452,12 +452,23 @@ denoting a specific output of a package."
packages) packages)
manifest-entry=?))) manifest-entry=?)))
(define (manifest->gexp manifest) (define %manifest-format-version
"Return a representation of MANIFEST as a gexp." ;; 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) (define (optional name value)
(match format-version
(4
(if (null? value) (if (null? value)
#~() #~()
#~((#$name #$value)))) #~((#$name #$value))))
(3
(match name
('properties #~((#$name #$@value)))
(_ #~((#$name #$value)))))))
(define (entry->gexp entry) (define (entry->gexp entry)
;; Maintain in state monad a vhash of visited entries, indexed by their ;; 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 ;; the presence of propagated inputs, where we could otherwise end up
;; repeating large trees. ;; repeating large trees.
(mlet %state-monad ((visited (current-state))) (mlet %state-monad ((visited (current-state)))
(if (match (vhash-assq (manifest-entry-item entry) visited) (if (and (= format-version 4)
(match (vhash-assq (manifest-entry-item entry) visited)
((_ . previous-entry) ((_ . previous-entry)
(manifest-entry=? previous-entry entry)) (manifest-entry=? previous-entry entry))
(#f #f)) (#f #f)))
(return #~(repeated #$(manifest-entry-name entry) (return #~(repeated #$(manifest-entry-name entry)
#$(manifest-entry-version entry) #$(manifest-entry-version entry)
(ungexp (manifest-entry-item entry) (ungexp (manifest-entry-item entry)
@ -500,9 +512,14 @@ denoting a specific output of a package."
search-paths)) search-paths))
#$@(optional 'properties properties)))))))))) #$@(optional 'properties properties))))))))))
(unless (memq format-version '(3 4))
(raise (formatted-message
(G_ "cannot emit manifests formatted as version ~a")
format-version)))
(match manifest (match manifest
(($ <manifest> (entries ...)) (($ <manifest> (entries ...))
#~(manifest (version 4) #~(manifest (version #$format-version)
(packages #$(run-with-state (packages #$(run-with-state
(mapm %state-monad entry->gexp entries) (mapm %state-monad entry->gexp entries)
vlist-null)))))) vlist-null))))))
@ -1883,6 +1900,7 @@ MANIFEST."
(allow-unsupported-packages? #f) (allow-unsupported-packages? #f)
(allow-collisions? #f) (allow-collisions? #f)
(relative-symlinks? #f) (relative-symlinks? #f)
(format-version %manifest-format-version)
system target) system target)
"Return a derivation that builds a profile (aka. 'user environment') with "Return a derivation that builds a profile (aka. 'user environment') with
the given MANIFEST. The profile includes additional derivations returned by 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) #+(if locales? set-utf8-locale #t)
(build-profile #$output '#$(manifest->gexp manifest) (build-profile #$output '#$(manifest->gexp manifest format-version)
#:extra-inputs '#$extra-inputs #:extra-inputs '#$extra-inputs
#:symlink #$(if relative-symlinks? #:symlink #$(if relative-symlinks?
#~symlink-relative #~symlink-relative
@ -2007,19 +2025,23 @@ are cross-built for TARGET."
(allow-collisions? profile-allow-collisions? ;Boolean (allow-collisions? profile-allow-collisions? ;Boolean
(default #f)) (default #f))
(relative-symlinks? profile-relative-symlinks? ;Boolean (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) (define-gexp-compiler (profile-compiler (profile <profile>) system target)
"Compile PROFILE to a derivation." "Compile PROFILE to a derivation."
(match profile (match profile
(($ <profile> name manifest hooks (($ <profile> name manifest hooks
locales? allow-collisions? relative-symlinks?) locales? allow-collisions? relative-symlinks?
format-version)
(profile-derivation manifest (profile-derivation manifest
#:name name #:name name
#:hooks hooks #:hooks hooks
#:locales? locales? #:locales? locales?
#:allow-collisions? allow-collisions? #:allow-collisions? allow-collisions?
#:relative-symlinks? relative-symlinks? #:relative-symlinks? relative-symlinks?
#:format-version format-version
#:system system #:target target)))) #:system system #:target target))))
(define* (profile-search-paths profile (define* (profile-search-paths profile

28
tests/profiles.scm
View File

@ -286,6 +286,34 @@
(string=? (dirname (readlink bindir)) (string=? (dirname (readlink bindir))
(derivation->output-path guile)))))) (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" (test-assertm "profile-derivation, ordering & collisions"
;; ENTRY1 and ENTRY2 both provide 'bin/guile'--a collision. Make sure ;; ENTRY1 and ENTRY2 both provide 'bin/guile'--a collision. Make sure
;; ENTRY1 "wins" over ENTRY2. See <https://bugs.gnu.org/49102>. ;; ENTRY1 "wins" over ENTRY2. See <https://bugs.gnu.org/49102>.