diff options
| -rw-r--r-- | guix/profiles.scm | 76 | ||||
| -rw-r--r-- | tests/profiles.scm | 22 |
2 files changed, 97 insertions, 1 deletions
diff --git a/guix/profiles.scm b/guix/profiles.scm index e921566e5a..7fff25ac5f 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -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 @@ #: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 @@ 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 @@ -244,6 +254,72 @@ Remove MANIFEST entries that have the same name and output as ENTRIES." ;;; +;;; 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. ;;; diff --git a/tests/profiles.scm b/tests/profiles.scm index b2919d7315..e1f1eefee7 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -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 @@ #: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 @@ (_ #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 |