nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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 2016-09-06 22:28:12 +02:00
parent c8c25704ae
commit 5239f3d908
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 85 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
guix/scripts/package.scm
View File

@ -261,25 +261,30 @@ synopsis or description matches all of REGEXPS."
((<) #t) ((<) #t)
(else #f))))) (else #f)))))
(define (upgraded-manifest-entry entry) (define (transaction-upgrade-entry entry transaction)
"Return either a <manifest-entry> corresponding to an upgrade of ENTRY, or "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a
#f if no upgrade was found." <manifest-entry>."
(match entry (match entry
(($ <manifest-entry> name version output (? string? path)) (($ <manifest-entry> name version output (? string? path))
(match (vhash-assoc name (find-newest-available-packages)) (match (vhash-assoc name (find-newest-available-packages))
((_ candidate-version pkg . rest) ((_ candidate-version pkg . rest)
(case (version-compare candidate-version version) (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 (let ((candidate-path (derivation->output-path
(package-derivation (%store) pkg)))) (package-derivation (%store) pkg))))
(and (not (string=? path candidate-path)) (if (string=? path candidate-path)
(package->manifest-entry pkg output)))))) transaction
(manifest-transaction-install-entry
(package->manifest-entry pkg output)
transaction))))))
(#f (#f
#f))))) transaction)))))
;;; ;;;
@ -559,17 +564,20 @@ upgrading, #f otherwise."
(output #f) (output #f)
(item item)))) (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', "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? (define upgrade?
(options->upgrade-predicate opts)) (options->upgrade-predicate opts))
(define to-upgrade (define upgraded
(filter-map (lambda (entry) (fold (lambda (entry transaction)
(and (upgrade? (manifest-entry-name entry)) (if (upgrade? (manifest-entry-name entry))
(upgraded-manifest-entry entry))) (transaction-upgrade-entry entry transaction)
(manifest-entries manifest))) transaction))
transaction
(manifest-entries manifest)))
(define to-install (define to-install
(filter-map (match-lambda (filter-map (match-lambda
@ -586,23 +594,29 @@ return the new list of manifest entries."
(_ #f)) (_ #f))
opts)) opts))
(append to-upgrade to-install)) (fold manifest-transaction-install-entry
upgraded
to-install))
(define (options->removable options manifest) (define (options->removable options manifest transaction)
"Given options, return the list of manifest patterns of packages to be "Given options, return a variant of TRANSACTION augmented with the list of
removed from MANIFEST." patterns of packages to remove."
(filter-map (match-lambda (fold (lambda (opt transaction)
(('remove . spec) (match opt
(call-with-values (('remove . spec)
(lambda () (call-with-values
(package-specification->name+version+output spec)) (lambda ()
(lambda (name version output) (package-specification->name+version+output spec))
(manifest-pattern (lambda (name version output)
(name name) (manifest-transaction-remove-pattern
(version version) (manifest-pattern
(output output))))) (name name)
(_ #f)) (version version)
options)) (output output))
transaction))))
(_ transaction)))
transaction
options))
(define (register-gc-root store profile) (define (register-gc-root store profile)
"Register PROFILE, a profile generation symlink, as a GC root, unless it "Register PROFILE, a profile generation symlink, as a GC root, unless it
@ -813,16 +827,18 @@ processed, #f otherwise."
opts) opts)
;; Then, process normal package installation/removal/upgrade. ;; Then, process normal package installation/removal/upgrade.
(let* ((manifest (profile-manifest profile)) (let* ((manifest (profile-manifest profile))
(install (options->installable opts manifest)) (step1 (options->installable opts manifest
(remove (options->removable opts manifest)) (manifest-transaction)))
(transaction (manifest-transaction (step2 (options->removable opts manifest step1))
(install (map transform-entry install)) (step3 (manifest-transaction
(remove remove))) (inherit step2)
(new (manifest-perform-transaction manifest transaction))) (install (map transform-entry
(manifest-transaction-install step2)))))
(new (manifest-perform-transaction manifest step3)))
(unless (and (null? install) (null? remove)) (unless (manifest-transaction-null? step3)
(show-manifest-transaction store manifest transaction (show-manifest-transaction store manifest step3
#:dry-run? dry-run?) #:dry-run? dry-run?)
(build-and-use-profile store profile new (build-and-use-profile store profile new
#:bootstrap? bootstrap? #:bootstrap? bootstrap?

29
tests/packages.scm
View File

@ -49,6 +49,7 @@
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
#:use-module (srfi srfi-64) #:use-module (srfi srfi-64)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (ice-9 vlist)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (ice-9 match)) #:use-module (ice-9 match))
@ -83,6 +84,34 @@
(and (hidden-package? (hidden-package (dummy-package "foo"))) (and (hidden-package? (hidden-package (dummy-package "foo")))
(not (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" (test-assert "package-field-location"
(let () (let ()
(define (goto port line column) (define (goto port line column)