ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

profiles: Add 'manifest-transaction'.

Browse source 
* guix/profiles.scm (<manifest-transaction>): New record-type.
  (manifest-perform-transaction): New procedure.
  (manifest-show-transaction): New procedure.
* tests/profiles.scm ("manifest-perform-transaction"): New test.

Co-authored-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Alex Kost 2014-08-14 00:03:53 +04:00 committed by Ludovic Courtès
parent 667b250846
commit 343745c80a
2 changed files with 97 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

76
guix/profiles.scm
View file

@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -18,6 +19,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix profiles)
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (guix derivations)
@ -26,6 +28,7 @@ (define-module (guix profiles)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 ftw)
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
@ -51,6 +54,13 @@ (define-module (guix profiles)
manifest-installed?
manifest-matching-entries
manifest-transaction
manifest-transaction?
manifest-transaction-install
manifest-transaction-remove
manifest-perform-transaction
manifest-show-transaction
profile-manifest
package->manifest-entry
profile-derivation
@ -242,6 +252,72 @@ (define (matches? entry)
(filter matches? (manifest-entries manifest)))
;;;
;;; Manifest transactions.
;;;
(define-record-type* <manifest-transaction> manifest-transaction
make-manifest-transaction
manifest-transaction?
(install manifest-transaction-install ; list of <manifest-entry>
(default '()))
(remove manifest-transaction-remove ; list of <manifest-pattern>
(default '())))
(define (manifest-perform-transaction manifest transaction)
"Perform TRANSACTION on MANIFEST and return new manifest."
(let ((install (manifest-transaction-install transaction))
(remove (manifest-transaction-remove transaction)))
(manifest-add (manifest-remove manifest remove)
install)))
(define* (manifest-show-transaction store manifest transaction
#:key dry-run?)
"Display what will/would be installed/removed from MANIFEST by TRANSACTION."
;; TODO: Report upgrades more clearly.
(let ((install (manifest-transaction-install transaction))
(remove (manifest-matching-entries
manifest (manifest-transaction-remove transaction))))
(match remove
((($ <manifest-entry> name version output path _) ..1)
(let ((len (length name))
(remove (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>)
name version output path)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be removed:~%~{~a~%~}~%"
"The following packages would be removed:~%~{~a~%~}~%"
len)
remove)
(format (current-error-port)
(N_ "The following package will be removed:~%~{~a~%~}~%"
"The following packages will be removed:~%~{~a~%~}~%"
len)
remove))))
(_ #f))
(match install
((($ <manifest-entry> name version output item _) ..1)
(let ((len (length name))
(install (map (lambda (name version output item)
(format #f " ~a-~a\t~a\t~a" name version output
(if (package? item)
(package-output store item output)
item)))
name version output item)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be installed:~%~{~a~%~}~%"
"The following packages would be installed:~%~{~a~%~}~%"
len)
install)
(format (current-error-port)
(N_ "The following package will be installed:~%~{~a~%~}~%"
"The following packages will be installed:~%~{~a~%~}~%"
len)
install))))
(_ #f))))
;;;
;;; Profiles.

22
tests/profiles.scm
View file

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@ -26,7 +27,7 @@ (define-module (test-profiles)
#:use-module (ice-9 match)
#:use-module (srfi srfi-64))
;; Test the (guix profile) module.
;; Test the (guix profiles) module.
(define %store
(open-connection))
@ -122,6 +123,25 @@ (define guile-2.0.9:debug
(_ #f))
(equal? m3 m4))))
(test-assert "manifest-perform-transaction"
(let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
(t1 (manifest-transaction
(install (list guile-1.8.8))
(remove (list (manifest-pattern (name "guile")
(output "debug"))))))
(t2 (manifest-transaction
(remove (list (manifest-pattern (name "guile")
(version "2.0.9")
(output #f))))))
(m1 (manifest-perform-transaction m0 t1))
(m2 (manifest-perform-transaction m1 t2))
(m3 (manifest-perform-transaction m0 t2)))
(and (match (manifest-entries m1)
((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
(_ #f))
(equal? m1 m2)
(null? (manifest-entries m3)))))
(test-assert "profile-derivation"
(run-with-store %store
(mlet* %store-monad