mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
guix package: Build up the transaction incrementally.
* guix/scripts/package.scm (upgraded-manifest-entry): Rename to...
(transaction-upgrade-entry): ... this. Add 'transaction' parameter and
return a transaction.
(options->installable): Likewise.
[to-upgrade]: Rename to...
[upgraded]: ... this, and change to be a transaction. Return a
transaction.
(options->removable): Likewise.
(process-actions): Adjust accordingly.
* tests/packages.scm ("transaction-upgrade-entry, zero upgrades")
("transaction-upgrade-entry, one upgrade"): New tests.
This commit is contained in:
Ludovic Courtès
parent
c8c25704ae
commit
5239f3d908
2 changed files with 85 additions and 40 deletions
|
|
@ -261,25 +261,30 @@ (define (matches-one? str)
|
|||
((<) #t)
|
||||
(else #f)))))
|
||||
|
||||
(define (upgraded-manifest-entry entry)
|
||||
"Return either a <manifest-entry> corresponding to an upgrade of ENTRY, or
|
||||
#f if no upgrade was found."
|
||||
(define (transaction-upgrade-entry entry transaction)
|
||||
"Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a
|
||||
<manifest-entry>."
|
||||
(match entry
|
||||
(($ <manifest-entry> name version output (? string? path))
|
||||
(match (vhash-assoc name (find-newest-available-packages))
|
||||
((_ candidate-version pkg . rest)
|
||||
(case (version-compare candidate-version version)
|
||||
((>)
|
||||
(package->manifest-entry pkg output))
|
||||
(manifest-transaction-install-entry
|
||||
(package->manifest-entry pkg output)
|
||||
transaction))
|
||||
((<)
|
||||
#f)
|
||||
transaction)
|
||||
((=)
|
||||
(let ((candidate-path (derivation->output-path
|
||||
(package-derivation (%store) pkg))))
|
||||
(and (not (string=? path candidate-path))
|
||||
(package->manifest-entry pkg output))))))
|
||||
(if (string=? path candidate-path)
|
||||
transaction
|
||||
(manifest-transaction-install-entry
|
||||
(package->manifest-entry pkg output)
|
||||
transaction))))))
|
||||
(#f
|
||||
#f)))))
|
||||
transaction)))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
@ -559,17 +564,20 @@ (define (store-item->manifest-entry item)
|
|||
(output #f)
|
||||
(item item))))
|
||||
|
||||
(define (options->installable opts manifest)
|
||||
(define (options->installable opts manifest transaction)
|
||||
"Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
|
||||
return the new list of manifest entries."
|
||||
return an variant of TRANSACTION that accounts for the specified installations
|
||||
and upgrades."
|
||||
(define upgrade?
|
||||
(options->upgrade-predicate opts))
|
||||
|
||||
(define to-upgrade
|
||||
(filter-map (lambda (entry)
|
||||
(and (upgrade? (manifest-entry-name entry))
|
||||
(upgraded-manifest-entry entry)))
|
||||
(manifest-entries manifest)))
|
||||
(define upgraded
|
||||
(fold (lambda (entry transaction)
|
||||
(if (upgrade? (manifest-entry-name entry))
|
||||
(transaction-upgrade-entry entry transaction)
|
||||
transaction))
|
||||
transaction
|
||||
(manifest-entries manifest)))
|
||||
|
||||
(define to-install
|
||||
(filter-map (match-lambda
|
||||
|
|
@ -586,23 +594,29 @@ (define to-install
|
|||
(_ #f))
|
||||
opts))
|
||||
|
||||
(append to-upgrade to-install))
|
||||
(fold manifest-transaction-install-entry
|
||||
upgraded
|
||||
to-install))
|
||||
|
||||
(define (options->removable options manifest)
|
||||
"Given options, return the list of manifest patterns of packages to be
|
||||
removed from MANIFEST."
|
||||
(filter-map (match-lambda
|
||||
(('remove . spec)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(package-specification->name+version+output spec))
|
||||
(lambda (name version output)
|
||||
(manifest-pattern
|
||||
(name name)
|
||||
(version version)
|
||||
(output output)))))
|
||||
(_ #f))
|
||||
options))
|
||||
(define (options->removable options manifest transaction)
|
||||
"Given options, return a variant of TRANSACTION augmented with the list of
|
||||
patterns of packages to remove."
|
||||
(fold (lambda (opt transaction)
|
||||
(match opt
|
||||
(('remove . spec)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(package-specification->name+version+output spec))
|
||||
(lambda (name version output)
|
||||
(manifest-transaction-remove-pattern
|
||||
(manifest-pattern
|
||||
(name name)
|
||||
(version version)
|
||||
(output output))
|
||||
transaction))))
|
||||
(_ transaction)))
|
||||
transaction
|
||||
options))
|
||||
|
||||
(define (register-gc-root store profile)
|
||||
"Register PROFILE, a profile generation symlink, as a GC root, unless it
|
||||
|
|
@ -813,16 +827,18 @@ (define (transform-entry entry)
|
|||
opts)
|
||||
|
||||
;; Then, process normal package installation/removal/upgrade.
|
||||
(let* ((manifest (profile-manifest profile))
|
||||
(install (options->installable opts manifest))
|
||||
(remove (options->removable opts manifest))
|
||||
(transaction (manifest-transaction
|
||||
(install (map transform-entry install))
|
||||
(remove remove)))
|
||||
(new (manifest-perform-transaction manifest transaction)))
|
||||
(let* ((manifest (profile-manifest profile))
|
||||
(step1 (options->installable opts manifest
|
||||
(manifest-transaction)))
|
||||
(step2 (options->removable opts manifest step1))
|
||||
(step3 (manifest-transaction
|
||||
(inherit step2)
|
||||
(install (map transform-entry
|
||||
(manifest-transaction-install step2)))))
|
||||
(new (manifest-perform-transaction manifest step3)))
|
||||
|
||||
(unless (and (null? install) (null? remove))
|
||||
(show-manifest-transaction store manifest transaction
|
||||
(unless (manifest-transaction-null? step3)
|
||||
(show-manifest-transaction store manifest step3
|
||||
#:dry-run? dry-run?)
|
||||
(build-and-use-profile store profile new
|
||||
#:bootstrap? bootstrap?
|
||||
|
|
|
|||
|
|
@ -49,6 +49,7 @@ (define-module (test-packages)
|
|||
#:use-module (srfi srfi-35)
|
||||
#:use-module (srfi srfi-64)
|
||||
#:use-module (rnrs io ports)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 match))
|
||||
|
||||
|
|
@ -83,6 +84,34 @@ (define %store
|
|||
(and (hidden-package? (hidden-package (dummy-package "foo")))
|
||||
(not (hidden-package? (dummy-package "foo")))))
|
||||
|
||||
(test-assert "transaction-upgrade-entry, zero upgrades"
|
||||
(let* ((old (dummy-package "foo" (version "1")))
|
||||
(tx (mock ((gnu packages) find-newest-available-packages
|
||||
(const vlist-null))
|
||||
((@@ (guix scripts package) transaction-upgrade-entry)
|
||||
(manifest-entry
|
||||
(inherit (package->manifest-entry old))
|
||||
(item (string-append (%store-prefix) "/"
|
||||
(make-string 32 #\e) "-foo-1")))
|
||||
(manifest-transaction)))))
|
||||
(manifest-transaction-null? tx)))
|
||||
|
||||
(test-assert "transaction-upgrade-entry, one upgrade"
|
||||
(let* ((old (dummy-package "foo" (version "1")))
|
||||
(new (dummy-package "foo" (version "2")))
|
||||
(tx (mock ((gnu packages) find-newest-available-packages
|
||||
(const (vhash-cons "foo" (list "2" new) vlist-null)))
|
||||
((@@ (guix scripts package) transaction-upgrade-entry)
|
||||
(manifest-entry
|
||||
(inherit (package->manifest-entry old))
|
||||
(item (string-append (%store-prefix) "/"
|
||||
(make-string 32 #\e) "-foo-1")))
|
||||
(manifest-transaction)))))
|
||||
(and (match (manifest-transaction-install tx)
|
||||
((($ <manifest-entry> "foo" "2" "out" item))
|
||||
(eq? item new)))
|
||||
(null? (manifest-transaction-remove tx)))))
|
||||
|
||||
(test-assert "package-field-location"
|
||||
(let ()
|
||||
(define (goto port line column)
|
||||
|
|
|
|||
Loading…
Reference in a new issue