>From 5fd45b3f4216921837f522d56b20c4be0a58fe8e Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Tue, 12 Aug 2014 13:54:23 +0400 Subject: [PATCH 2/2] guix package: Add 'process-package-actions'. * guix/scripts/package.scm (process-package-actions): New procedure. (guix-package): Use it. [ensure-default-profile]: Move to top-level. [substitutes?]: New variable. [same-package?]: Remove. (options->installable, options->removable): Change according to 'process-package-actions'. --- guix/scripts/package.scm | 336 +++++++++++++++++++++++------------------------ 1 file changed, 166 insertions(+), 170 deletions(-) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 4eb046e..2719b74 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 @@ -619,21 +620,15 @@ 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 (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 @@ -653,59 +648,18 @@ return the new list of manifest entries." (_ #f)) (manifest-entries manifest))))) - (define to-upgrade - (map (match-lambda - ((package output) - (package->manifest-entry* package output))) - packages-to-upgrade)) - (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)) @@ -724,6 +678,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. @@ -742,65 +840,12 @@ removed from MANIFEST." %default-options #f)) - (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 profile (assoc-ref opts 'profile)) - - (define (same-package? entry name output) - (match 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 profile (assoc-ref opts 'profile)) (define current-generation-number (generation-number profile)) @@ -869,61 +914,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 - (($ 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 -- 2.0.3