Hello, Ludovic and happy vacations :)
Alex Kost (2014-07-26 21:44 +0400) wrote:
> Ludovic Courtès (2014-07-26 00:36 +0400) wrote:
>
> [...]
>
>> Namely, (guix scripts package) needs to be made more modular, and the
>> generic bits must be moved to (guix profiles). Now that there’s a
>> second consumer for this API, there’s more of an incentive to do it.
>>
>> I’m willing to help for that, but I’m happy if you give it a try.
>> WDYT?
>
> Sure, I'll do what I can, however the quality of my try may be
> unsatisfactory. Anyway I think I'll send a patch in several days.
You are probably reading this a couple of weeks from now so my changes
may not be actual, but anyway I'm attaching a patch with the changes.
Here is what I've done:
- A part of code for installing/upgrading/removing was extracted from
‘guix-package’ function (from ‘process-actions’ more precisely). So
the new function (I named it ‘process-package-actions’) can be used in
"guix.el".
- A bit of code was placed into "profiles.scm" as ‘manifest-add’.
- Also I think you forgot (?) to remove ‘deduplicate’ function in commit
4ca0b41, so I did it as well.
I hope something of the above is acceptable. WDYT?
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 5e69e01..8533af5 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -47,6 +47,7 @@
manifest-pattern?
manifest-remove
+ manifest-add
manifest-installed?
manifest-matching-entries
@@ -196,6 +197,25 @@ must be a manifest-pattern."
(manifest-entries manifest)
patterns)))
+(define (manifest-add manifest entries)
+ "Add ENTRIES to MANIFEST and return new manifest.
+Remove MANIFEST entries that have the same name and output as ENTRIES."
+ (define (same-entry? entry name output)
+ (match entry
+ (($ <manifest-entry> entry-name _ entry-output _ ...)
+ (and (equal? name entry-name)
+ (equal? output entry-output)))))
+
+ (make-manifest
+ (append entries
+ (fold (lambda (entry result)
+ (match entry
+ (($ <manifest-entry> name _ out _ ...)
+ (filter (negate (cut same-entry? <> name out))
+ result))))
+ (manifest-entries manifest)
+ entries))))
+
(define (manifest-installed? manifest pattern)
"Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
#f otherwise."
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 31da773..09c1bf1 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -44,6 +44,7 @@
#:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
#:use-module (guix gnu-maintenance)
#:export (specification->package+output
+ process-package-actions
guix-package))
(define %store
@@ -620,112 +621,46 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
%standard-build-options))
-(define (options->installable opts manifest)
- "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
-return the new list of manifest entries."
- (define (deduplicate deps)
- ;; Remove duplicate entries from DEPS, a list of propagated inputs, where
- ;; each input is a name/path tuple.
- (define (same? d1 d2)
- (match d1
- ((_ p1)
- (match d2
- ((_ p2) (eq? p1 p2))
- (_ #f)))
- ((_ p1 out1)
- (match d2
- ((_ p2 out2)
- (and (string=? out1 out2)
- (eq? p1 p2)))
- (_ #f)))))
-
- (delete-duplicates deps same?))
-
- (define (package->manifest-entry* package output)
- (check-package-freshness package)
- ;; When given a package via `-e', install the first of its
- ;; outputs (XXX).
- (package->manifest-entry package output))
-
+(define (options->installable options manifest)
+ "Given OPTIONS, return a list of patterns for installing/upgrading.
+Returned list is suitable for 'process-package-actions'."
(define upgrade-regexps
(filter-map (match-lambda
(('upgrade . regexp)
(make-regexp (or regexp "")))
(_ #f))
- opts))
+ options))
(define packages-to-upgrade
(match upgrade-regexps
(()
'())
((_ ...)
- (let ((newest (find-newest-available-packages)))
- (filter-map (match-lambda
- (($ <manifest-entry> name version output path _)
- (and (any (cut regexp-exec <> name)
- upgrade-regexps)
- (upgradeable? name version path)
- (let ((output (or output "out")))
- (call-with-values
- (lambda ()
- (specification->package+output name output))
- list))))
- (_ #f))
- (manifest-entries manifest))))))
-
- (define to-upgrade
- (map (match-lambda
- ((package output)
- (package->manifest-entry* package output)))
- packages-to-upgrade))
+ (filter-map (match-lambda
+ (($ <manifest-entry> name version output path _)
+ (and (any (cut regexp-exec <> name)
+ upgrade-regexps)
+ (upgradeable? name version path)
+ (let ((output (or output "out")))
+ (call-with-values
+ (lambda ()
+ (specification->package+output name output))
+ list))))
+ (_ #f))
+ (manifest-entries manifest)))))
(define packages-to-install
(filter-map (match-lambda
- (('install . (? package? p))
- (list p "out"))
- (('install . (? string? spec))
- (and (not (store-path? spec))
- (let-values (((package output)
- (specification->package+output spec)))
- (and package (list package output)))))
+ (('install . package) package)
(_ #f))
- opts))
-
- (define to-install
- (append (map (match-lambda
- ((package output)
- (package->manifest-entry* package output)))
- packages-to-install)
- (filter-map (match-lambda
- (('install . (? package?))
- #f)
- (('install . (? store-path? path))
- (let-values (((name version)
- (package-name->name+version
- (store-path-package-name path))))
- (manifest-entry
- (name name)
- (version version)
- (output #f)
- (item path))))
- (_ #f))
- opts)))
-
- (append to-upgrade to-install))
-
-(define (options->removable options manifest)
- "Given options, return the list of manifest patterns of packages to be
-removed from MANIFEST."
+ options))
+
+ (append packages-to-upgrade packages-to-install))
+
+(define (options->removable options)
+ "Given OPTIONS, return a list of package specifications for deleting."
(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)))))
+ (('remove . spec) spec)
(_ #f))
options))
@@ -744,6 +679,150 @@ removed from MANIFEST."
file
(apply throw args)))))
+(define (ensure-default-profile)
+ "Ensure the default profile symlink and directory exist and are
+writable."
+ (define (rtfm)
+ (format (current-error-port)
+ (_ "Try \"info '(guix) Invoking guix package'\" for \
+more information.~%"))
+ (exit 1))
+
+ ;; Create ~/.guix-profile if it doesn't exist yet.
+ (when (and %user-profile-directory
+ %current-profile
+ (not (false-if-exception
+ (lstat %user-profile-directory))))
+ (symlink %current-profile %user-profile-directory))
+
+ (let ((s (stat %profile-directory #f)))
+ ;; Attempt to create /…/profiles/per-user/$USER if needed.
+ (unless (and s (eq? 'directory (stat:type s)))
+ (catch 'system-error
+ (lambda ()
+ (mkdir-p %profile-directory))
+ (lambda args
+ ;; Often, we cannot create %PROFILE-DIRECTORY because its
+ ;; parent directory is root-owned and we're running
+ ;; unprivileged.
+ (format (current-error-port)
+ (_ "error: while creating directory `~a': ~a~%")
+ %profile-directory
+ (strerror (system-error-errno args)))
+ (format (current-error-port)
+ (_ "Please create the `~a' directory, with you as the owner.~%")
+ %profile-directory)
+ (rtfm))))
+
+ ;; Bail out if it's not owned by the user.
+ (unless (or (not s) (= (stat:uid s) (getuid)))
+ (format (current-error-port)
+ (_ "error: directory `~a' is not owned by you~%")
+ %profile-directory)
+ (format (current-error-port)
+ (_ "Please change the owner of `~a' to user ~s.~%")
+ %profile-directory (or (getenv "USER")
+ (getenv "LOGNAME")
+ (getuid)))
+ (rtfm))))
+
+(define* (process-package-actions store profile
+ #:key (install '()) (remove '())
+ dry-run? (use-substitutes? #t))
+ "Install/remove packages.
+
+INSTALL is a list of package patterns for installation. Each element of
+the list may be a package, a list (PACKAGE OUTPUT), a string with name
+specification or a store path.
+
+REMOVE is a list of name specifications for removing from PROFILE
+manifest."
+ (define (package->manifest-entry* package output)
+ (check-package-freshness package)
+ ;; When given a package via `-e', install the first of its
+ ;; outputs (XXX).
+ (package->manifest-entry package output))
+
+ (define (entries-to-install install)
+ ;; Return a list of manifest entries for installing.
+ (filter-map (match-lambda
+ ((? package? package)
+ (package->manifest-entry* package "out"))
+ (((? package? package) output)
+ (package->manifest-entry* package output))
+ ((? string? spec-or-path)
+ (if (store-path? spec-or-path)
+ (let-values (((name version)
+ (package-name->name+version
+ (store-path-package-name spec-or-path))))
+ (manifest-entry
+ (name name)
+ (version version)
+ (output #f)
+ (item spec-or-path)))
+ (let-values (((package output)
+ (specification->package+output spec-or-path)))
+ (and package (package->manifest-entry* package output)))))
+ (_ #f))
+ install))
+
+ (define (patterns-to-remove remove)
+ ;; Return a list of manifest patterns for removing.
+ (map (lambda (spec)
+ (call-with-values
+ (lambda ()
+ (package-specification->name+version+output spec))
+ (lambda (name version output)
+ (manifest-pattern
+ (name name)
+ (version version)
+ (output output)))))
+ remove))
+
+ (let* ((manifest (profile-manifest profile))
+ (install (entries-to-install install))
+ (remove (patterns-to-remove remove))
+ (new (manifest-add (manifest-remove manifest remove)
+ install))
+ (entries (manifest-entries new)))
+
+ (unless (and (null? install) (null? remove))
+ (when (equal? profile %current-profile)
+ (ensure-default-profile))
+
+ (let* ((prof-drv (run-with-store store (profile-derivation new)))
+ (prof (derivation->output-path prof-drv))
+ (remove (manifest-matching-entries manifest remove)))
+ (show-what-to-remove/install remove install dry-run?)
+ (show-what-to-build store (list prof-drv)
+ #:use-substitutes? use-substitutes?
+ #:dry-run? dry-run?)
+
+ (cond
+ (dry-run? #t)
+ ((and (file-exists? profile)
+ (and=> (readlink* profile) (cut string=? prof <>)))
+ (format (current-error-port) (_ "nothing to be done~%")))
+ (else
+ (let* ((number (generation-number profile))
+
+ ;; Always use NUMBER + 1 for the new profile,
+ ;; possibly overwriting a "previous future
+ ;; generation".
+ (name (generation-file-name profile
+ (+ 1 number))))
+ (and (build-derivations store (list prof-drv))
+ (let ((count (length entries)))
+ (switch-symlinks name prof)
+ (switch-symlinks profile name)
+ (maybe-register-gc-root store profile)
+ (format #t (N_ "~a package in profile~%"
+ "~a packages in profile~%"
+ count)
+ count)
+ (display-search-paths entries
+ profile))))))))))
+
;;;
;;; Entry point.
@@ -767,66 +846,13 @@ removed from MANIFEST."
(let ((out (derivation->output-path (%guile-for-build))))
(not (valid-path? (%store) out))))
- (define (ensure-default-profile)
- ;; Ensure the default profile symlink and directory exist and are
- ;; writable.
-
- (define (rtfm)
- (format (current-error-port)
- (_ "Try \"info '(guix) Invoking guix package'\" for \
-more information.~%"))
- (exit 1))
-
- ;; Create ~/.guix-profile if it doesn't exist yet.
- (when (and %user-profile-directory
- %current-profile
- (not (false-if-exception
- (lstat %user-profile-directory))))
- (symlink %current-profile %user-profile-directory))
-
- (let ((s (stat %profile-directory #f)))
- ;; Attempt to create /…/profiles/per-user/$USER if needed.
- (unless (and s (eq? 'directory (stat:type s)))
- (catch 'system-error
- (lambda ()
- (mkdir-p %profile-directory))
- (lambda args
- ;; Often, we cannot create %PROFILE-DIRECTORY because its
- ;; parent directory is root-owned and we're running
- ;; unprivileged.
- (format (current-error-port)
- (_ "error: while creating directory `~a': ~a~%")
- %profile-directory
- (strerror (system-error-errno args)))
- (format (current-error-port)
- (_ "Please create the `~a' directory, with you as the owner.~%")
- %profile-directory)
- (rtfm))))
-
- ;; Bail out if it's not owned by the user.
- (unless (or (not s) (= (stat:uid s) (getuid)))
- (format (current-error-port)
- (_ "error: directory `~a' is not owned by you~%")
- %profile-directory)
- (format (current-error-port)
- (_ "Please change the owner of `~a' to user ~s.~%")
- %profile-directory (or (getenv "USER")
- (getenv "LOGNAME")
- (getuid)))
- (rtfm))))
-
(define (process-actions opts)
;; Process any install/remove/upgrade action from OPTS.
- (define dry-run? (assoc-ref opts 'dry-run?))
- (define verbose? (assoc-ref opts 'verbose?))
- (define profile (assoc-ref opts 'profile))
-
- (define (same-package? entry name output)
- (match entry
- (($ <manifest-entry> entry-name _ entry-output _ ...)
- (and (equal? name entry-name)
- (equal? output entry-output)))))
+ (define substitutes? (assoc-ref opts 'substitutes?))
+ (define dry-run? (assoc-ref opts 'dry-run?))
+ (define verbose? (assoc-ref opts 'verbose?))
+ (define profile (assoc-ref opts 'profile))
(define current-generation-number
(generation-number profile))
@@ -895,61 +921,12 @@ more information.~%"))
(_ #f))
opts))
(else
- (let* ((manifest (profile-manifest profile))
- (install (options->installable opts manifest))
- (remove (options->removable opts manifest))
- (entries
- (append install
- (fold (lambda (package result)
- (match package
- (($ <manifest-entry> name _ out _ ...)
- (filter (negate
- (cut same-package? <>
- name out))
- result))))
- (manifest-entries
- (manifest-remove manifest remove))
- install)))
- (new (make-manifest entries)))
-
- (when (equal? profile %current-profile)
- (ensure-default-profile))
-
- (unless (and (null? install) (null? remove))
- (let* ((prof-drv (run-with-store (%store)
- (profile-derivation new)))
- (prof (derivation->output-path prof-drv))
- (remove (manifest-matching-entries manifest remove)))
- (show-what-to-remove/install remove install dry-run?)
- (show-what-to-build (%store) (list prof-drv)
- #:use-substitutes?
- (assoc-ref opts 'substitutes?)
- #:dry-run? dry-run?)
-
- (cond
- (dry-run? #t)
- ((and (file-exists? profile)
- (and=> (readlink* profile) (cut string=? prof <>)))
- (format (current-error-port) (_ "nothing to be done~%")))
- (else
- (let* ((number (generation-number profile))
-
- ;; Always use NUMBER + 1 for the new profile,
- ;; possibly overwriting a "previous future
- ;; generation".
- (name (generation-file-name profile
- (+ 1 number))))
- (and (build-derivations (%store) (list prof-drv))
- (let ((count (length entries)))
- (switch-symlinks name prof)
- (switch-symlinks profile name)
- (maybe-register-gc-root (%store) profile)
- (format #t (N_ "~a package in profile~%"
- "~a packages in profile~%"
- count)
- count)
- (display-search-paths entries
- profile))))))))))))
+ (process-package-actions
+ (%store) profile
+ #:install (options->installable opts (profile-manifest profile))
+ #:remove (options->removable opts)
+ #:use-substitutes? substitutes?
+ #:dry-run? dry-run?))))
(define (process-query opts)
;; Process any query specified by OPTS. Return #t when a query was
