From mboxrd@z Thu Jan 1 00:00:00 1970 From: Alex Kost Subject: Re: Emacs interface for Guix Date: Mon, 28 Jul 2014 14:15:02 +0400 Message-ID: <87a97taixl.fsf@gmail.com> References: <87k3719v7p.fsf@gmail.com> <87r419fa50.fsf@gnu.org> <87fvho9fqm.fsf@gmail.com> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:51799) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XBhxX-0007g7-UT for guix-devel@gnu.org; Mon, 28 Jul 2014 06:15:21 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1XBhxO-0007P7-Jw for guix-devel@gnu.org; Mon, 28 Jul 2014 06:15:11 -0400 In-Reply-To: <87fvho9fqm.fsf@gmail.com> (Alex Kost's message of "Sat, 26 Jul 2014 21:44:49 +0400") List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org To: Ludovic =?utf-8?Q?Court=C3=A8s?= Cc: guix-devel@gnu.org --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Hello, Ludovic and happy vacations :) Alex Kost (2014-07-26 21:44 +0400) wrote: > Ludovic Court=C3=A8s (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=E2=80=99s= a >> second consumer for this API, there=E2=80=99s more of an incentive to do= it. >> >> I=E2=80=99m willing to help for that, but I=E2=80=99m 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 =E2=80=98guix-package=E2=80=99 function (from =E2=80=98process-actions=E2= =80=99 more precisely). So the new function (I named it =E2=80=98process-package-actions=E2=80=99) c= an be used in "guix.el". - A bit of code was placed into "profiles.scm" as =E2=80=98manifest-add=E2= =80=99. - Also I think you forgot (?) to remove =E2=80=98deduplicate=E2=80=99 funct= ion in commit 4ca0b41, so I did it as well. I hope something of the above is acceptable. WDYT? --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: attachment; filename=guix.diff Content-Transfer-Encoding: quoted-printable 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? =20 manifest-remove + manifest-add manifest-installed? manifest-matching-entries =20 @@ -196,6 +197,25 @@ must be a manifest-pattern." (manifest-entries manifest) patterns))) =20 +(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 + (($ entry-name _ entry-output _ ...) + (and (equal? name entry-name) + (equal? output entry-output))))) + + (make-manifest + (append entries + (fold (lambda (entry result) + (match 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)) =20 (define %store @@ -620,112 +621,46 @@ Install, remove, or upgrade PACKAGES in a single tra= nsaction.\n")) =20 %standard-build-options)) =20 -(define (options->installable opts manifest) - "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fol= d', -return the new list of manifest entries." - (define (deduplicate deps) - ;; Remove duplicate entries from DEPS, a list of propagated inputs, wh= ere - ;; 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=3D? 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)) =20 (define packages-to-upgrade (match upgrade-regexps (() '()) ((_ ...) - (let ((newest (find-newest-available-packages))) - (filter-map (match-lambda - (($ 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 ou= tput)) - 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 + (($ 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 outp= ut)) + list)))) + (_ #f)) + (manifest-entries manifest))))) =20 (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)) =20 @@ -744,6 +679,150 @@ removed from MANIFEST." file (apply throw args))))) =20 +(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 /=E2=80=A6/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 ow= ner.~%") + %profile-directory) + (rtfm)))) + + ;; Bail out if it's not owned by the user. + (unless (or (not s) (=3D (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 out= put))))) + (_ #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=3D> (readlink* profile) (cut string=3D? 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)))) =20 - (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 /=E2=80=A6/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) (=3D (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. =20 - (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 - (($ 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)) =20 (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 - (($ 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=3D> (readlink* profile) (cut string=3D? 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?)))) =20 (define (process-query opts) ;; Process any query specified by OPTS. Return #t when a query was --=-=-=--