From mboxrd@z Thu Jan 1 00:00:00 1970 From: Alex Kost Subject: [PATCH] Emacs interface for Guix Date: Tue, 12 Aug 2014 14:19:48 +0400 Message-ID: <87tx5idn7f.fsf_-_@gmail.com> References: <87k3719v7p.fsf@gmail.com> <87r419fa50.fsf@gnu.org> <87fvho9fqm.fsf@gmail.com> <87a97taixl.fsf@gmail.com> <87sil2rbly.fsf@gnu.org> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:49023) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1XH9BP-0000Ls-Hj for guix-devel@gnu.org; Tue, 12 Aug 2014 06:20:08 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1XH9BF-0006mE-OX for guix-devel@gnu.org; Tue, 12 Aug 2014 06:19:59 -0400 In-Reply-To: <87sil2rbly.fsf@gnu.org> ("Ludovic \=\?utf-8\?Q\?Court\=C3\=A8s\=22'\?\= \=\?utf-8\?Q\?s\?\= message of "Mon, 11 Aug 2014 22:54:17 +0200") 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 Court=C3=A8s (2014-08-12 00:54 +0400) wrote: > Alex Kost skribis: > >> - 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= ) can be used in >> "guix.el". > > That looks good, but could you make it a separate patch? > > In general, it=E2=80=99s better to send atomic changes, with a commit log= , in > the format produced by =E2=80=98git format-patch=E2=80=99 (see HACKING.) = That > facilitates review and incremental changes. Thanks for pointing. I've never contributed to a real project, so I don't know the rules actually :) >> - A bit of code was placed into "profiles.scm" as =E2=80=98manifest-add= =E2=80=99. > > Good idea. Could you send a single patch for this change? I=E2=80=99ll = even > add a couple of test cases in tests/profiles.scm for the new procedure > if you don=E2=80=99t do it yourself. :-) Ok, I'm attaching 2 patches with =E2=80=98manifest-add=E2=80=99 and =E2=80=98process-package-actions=E2=80=99. What should be changed/improved= there? --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-profiles-Add-manifest-add.patch >From af4b8495969d70d59aa9f3f296628daeaf80b0d2 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Tue, 12 Aug 2014 12:32:16 +0400 Subject: [PATCH 1/2] profiles: Add 'manifest-add'. * guix/profiles.scm (manifest-add): New procedure. * tests/profiles.scm (guile-1.8.8): New variable. ("manifest-add"): New test. --- guix/profiles.scm | 20 ++++++++++++++++++++ tests/profiles.scm | 21 +++++++++++++++++++++ 2 files changed, 41 insertions(+) diff --git a/guix/profiles.scm b/guix/profiles.scm index 5e69e01..c7aec79 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 a list of manifest 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/tests/profiles.scm b/tests/profiles.scm index d405f64..b2919d7 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -40,6 +40,13 @@ ;; Example manifest entries. +(define guile-1.8.8 + (manifest-entry + (name "guile") + (version "1.8.8") + (item "/gnu/store/...") + (output "out"))) + (define guile-2.0.9 (manifest-entry (name "guile") @@ -101,6 +108,20 @@ (null? (manifest-entries m3)) (null? (manifest-entries m4))))))) +(test-assert "manifest-add" + (let* ((m0 (manifest '())) + (m1 (manifest-add m0 (list guile-1.8.8))) + (m2 (manifest-add m1 (list guile-2.0.9))) + (m3 (manifest-add m2 (list guile-2.0.9:debug))) + (m4 (manifest-add m3 (list guile-2.0.9:debug)))) + (and (match (manifest-entries m1) + ((($ "guile" "1.8.8" "out")) #t) + (_ #f)) + (match (manifest-entries m2) + ((($ "guile" "2.0.9" "out")) #t) + (_ #f)) + (equal? m3 m4)))) + (test-assert "profile-derivation" (run-with-store %store (mlet* %store-monad -- 2.0.3 --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: attachment; filename=0002-guix-package-Add-process-package-actions.patch Content-Transfer-Encoding: quoted-printable >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)) =20 (define %store @@ -619,21 +620,15 @@ Install, remove, or upgrade PACKAGES in a single tran= saction.\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 (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 @@ -653,59 +648,18 @@ return the new list of manifest entries." (_ #f)) (manifest-entries manifest))))) =20 - (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)) =20 @@ -724,6 +678,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. @@ -742,65 +840,12 @@ removed from MANIFEST." %default-options #f)) =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 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)) =20 (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=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 --=20 2.0.3 --=-=-=--