From mboxrd@z Thu Jan 1 00:00:00 1970 From: Nikita Karetnikov Subject: [PATCH] guix package: Add '--delete-generations'. Date: Sun, 22 Sep 2013 23:19:14 +0400 Message-ID: <87li2oslzh.fsf_-_@karetnikov.org> References: <87vc2o4qwc.fsf@gnu.org> <87y57kljro.fsf@karetnikov.org> <87hae81uvo.fsf@gnu.org> Mime-Version: 1.0 Content-Type: multipart/signed; boundary="==-=-="; micalg=pgp-sha1; protocol="application/pgp-signature" Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:47175) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1VNp75-0002Gw-Ji for guix-devel@gnu.org; Sun, 22 Sep 2013 15:14:37 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1VNp73-0004GZ-G6 for guix-devel@gnu.org; Sun, 22 Sep 2013 15:14:35 -0400 In-Reply-To: <87hae81uvo.fsf@gnu.org> ("Ludovic =?utf-8?Q?Court=C3=A8s=22'?= =?utf-8?Q?s?= message of "Thu, 29 Aug 2013 15:36:43 +0200") List-Id: 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: multipart/mixed; boundary="=-=-=" --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Can I push this patch to =E2=80=98master=E2=80=99? Do you see any problems? I had noticed that =E2=80=98--roll-back=E2=80=99 doesn=E2=80=99t output any= thing with =E2=80=98--dry-run=E2=80=99, so I implemented =E2=80=98--delete-generations= =E2=80=99 similarly. Maybe it would be better to print something. WDYT? --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=0001-guix-package-Add-delete-generations.patch Content-Transfer-Encoding: quoted-printable From=20ede983c90bd4cdece708820e1d52a2d1894a51c8 Mon Sep 17 00:00:00 2001 From: Nikita Karetnikov Date: Sun, 22 Sep 2013 18:50:06 +0000 Subject: [PATCH] guix package: Add '--delete-generations'. * guix/scripts/package.scm (link-to-empty-environment) (switch-to-previous-generation): New functions. (roll-back): Replace internal functions with the new ones. (show-help): Add '--delete-generations'. (%options): Likewise. (guix-package): Add 'apply-to-generations'. (guix-package)[process-actions]: Add support for '--delete-generations'. (guix-package)[process-query]: Replace 'cond' with 'apply-to-generations'. * tests/guix-package.sh: Test '--delete-generations'. * doc/guix.texi (Invoking guix-package): Document '--delete-generations'. =2D-- doc/guix.texi | 7 ++ guix/scripts/package.scm | 271 ++++++++++++++++++++++++++++--------------= ---- tests/guix-package.sh | 7 ++ 3 files changed, 178 insertions(+), 107 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index fdddcc5..3d61630 100644 =2D-- a/doc/guix.texi +++ b/doc/guix.texi @@ -639,6 +639,13 @@ or months by passing an integer along with the first l= etter of the duration, e.g., @code{--list-generations=3D20d}. @end itemize =20 +@item --delete-generations[=3D@var{pattern}] +@itemx -d [@var{pattern}] +Delete generations. + +When @var{pattern} is specified, delete only the matching generations. +This command accepts the same patterns as @option{--list-generations}. + @item --profile=3D@var{profile} @itemx -p @var{profile} Use @var{profile} instead of the user's default profile. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index c0cedcd..c72b56e 100644 =2D-- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -214,6 +214,25 @@ all of PACKAGES, a list of name/version/output/path/de= ps tuples." (compose string->number (cut match:substring <> 1))) 0)) =20 +(define (link-to-empty-environment generation) + "Link GENERATION, a string, to the empty environment." + (let* ((drv (profile-derivation (%store) '())) + (prof (derivation->output-path drv "out"))) + (when (not (build-derivations (%store) (list drv))) + (leave (_ "failed to build the empty profile~%"))) + + (switch-symlinks generation prof))) + +(define (switch-to-previous-generation profile) + "Atomically switch PROFILE to the previous generation." + (let* ((number (generation-number profile)) + (previous-number (previous-generation-number profile number)) + (previous-generation (format #f "~a-~a-link" + profile previous-number))) + (format #t (_ "switching from generation ~a to ~a~%") + number previous-number) + (switch-symlinks profile previous-generation))) + (define (roll-back profile) "Roll back to the previous generation of PROFILE." (let* ((number (generation-number profile)) @@ -222,28 +241,18 @@ all of PACKAGES, a list of name/version/output/path/d= eps tuples." profile previous-number)) (manifest (string-append previous-generation "/manifes= t"))) =20 =2D (define (switch-link) =2D ;; Atomically switch PROFILE to the previous generation. =2D (format #t (_ "switching from generation ~a to ~a~%") =2D number previous-number) =2D (switch-symlinks profile previous-generation)) =2D =2D (cond ((not (file-exists? profile)) ; invalid profile + (cond ((not (file-exists? profile)) ; invalid profile (leave (_ "profile `~a' does not exist~%") profile)) =2D ((zero? number) ; empty profile + ((zero? number) ; empty profile (format (current-error-port) (_ "nothing to do: already at the empty profile~%"))) =2D ((or (zero? previous-number) ; going to emptiness + ((or (zero? previous-number) ; going to emptine= ss (not (file-exists? previous-generation))) =2D (let* ((drv (profile-derivation (%store) '())) =2D (prof (derivation->output-path drv "out"))) =2D (when (not (build-derivations (%store) (list drv))) =2D (leave (_ "failed to build the empty profile~%"))) =2D =2D (switch-symlinks previous-generation prof) =2D (switch-link))) =2D (else (switch-link))))) ; anything else + (begin (link-to-empty-environment previous-generation) + (switch-to-previous-generation profile))) + (else + (switch-to-previous-generation profile))))) ; anything else =20 (define (generation-time profile number) "Return the creation time of a generation in the UTC format." @@ -511,6 +520,9 @@ Install, remove, or upgrade PACKAGES in a single transa= ction.\n")) (display (_ " -l, --list-generations[=3DPATTERN] list generations matching PATTERN")) + (display (_ " + -d, --delete-generations[=3DPATTERN] + delete generations matching PATTERN")) (newline) (display (_ " -p, --profile=3DPROFILE use PROFILE instead of the user's default profi= le")) @@ -574,6 +586,10 @@ Install, remove, or upgrade PACKAGES in a single trans= action.\n")) (lambda (opt name arg result) (cons `(query list-generations ,(or arg "")) result))) + (option '(#\d "delete-generations") #f #t + (lambda (opt name arg result) + (alist-cons 'delete-generations (or arg "") + result))) (option '("search-paths") #f #f (lambda (opt name arg result) (cons `(query search-paths) result))) @@ -742,6 +758,20 @@ more information.~%")) %profile-directory (or (getenv "USER") (getuid))) (rtfm)))) =20 + (define (apply-to-generations function profile pattern) + (cond ((not (file-exists? profile)) ; XXX: race condition + (leave (_ "profile '~a' does not exist~%") + profile)) + ((string-null? pattern) + (for-each function + (generation-numbers profile))) + ((matching-generations pattern profile) + =3D> + (cut for-each function <>)) + (else + (leave (_ "invalid syntax: ~a~%") + pattern)))) + (define (process-actions opts) ;; Process any install/remove/upgrade action from OPTS. =20 @@ -824,85 +854,123 @@ more information.~%")) install)))) (_ #f))) =20 + (define (delete-generation number) + (define (display-and-delete generation) + (begin (format #t "deleting ~a~%" generation) + (delete-file generation))) + + (define (current-generation? profile generation) + (string=3D? (readlink profile) generation)) + + (let* ((generation (format #f "~a-~a-link" profile number)) + (previous-number (previous-generation-number profile number)) + (previous-generation (format #f "~a-~a-link" + profile previous-number))) + (cond ((zero? number)) ; do not delete generation 0 + ((and (current-generation? profile generation) + (not (file-exists? previous-generation))) + (begin (link-to-empty-environment previous-generation) + (switch-to-previous-generation profile) + (display-and-delete generation))) + ((current-generation? profile generation) + (begin (roll-back profile) + (display-and-delete generation))) + (else + (display-and-delete generation))))) + ;; First roll back if asked to. =2D (if (and (assoc-ref opts 'roll-back?) (not dry-run?)) =2D (begin =2D (roll-back profile) =2D (process-actions (alist-delete 'roll-back? opts))) =2D (let* ((installed (manifest-packages (profile-manifest profile))) =2D (upgrade-regexps (filter-map (match-lambda =2D (('upgrade . regexp) =2D (make-regexp (or regexp ""= ))) =2D (_ #f)) =2D opts)) =2D (upgrade (if (null? upgrade-regexps) =2D '() =2D (let ((newest (find-newest-available-packag= es))) =2D (filter-map (match-lambda =2D ((name version output path _) =2D (and (any (cut regexp-exec = <> name) =2D upgrade-regexps) =2D (upgradeable? name ver= sion path) =2D (find-package name =2D (or outp= ut "out")))) =2D (_ #f)) =2D installed)))) =2D (install (append =2D upgrade =2D (filter-map (match-lambda =2D (('install . (? package? p)) =2D (package->tuple p)) =2D (('install . (? store-path?)) =2D #f) =2D (('install . package) =2D (find-package package)) =2D (_ #f)) =2D opts))) =2D (drv (filter-map (match-lambda =2D ((name version sub-drv =2D (? package? package) =2D (deps ...)) =2D (check-package-freshness package) =2D (package-derivation (%store) pack= age)) =2D (_ #f)) =2D install)) =2D (install* (append =2D (filter-map (match-lambda =2D (('install . (? package? p)) =2D #f) =2D (('install . (? store-path? path)) =2D (let-values (((name version) =2D (package-name->nam= e+version =2D (store-path-packa= ge-name =2D path)))) =2D `(,name ,version #f ,path ()))) + (cond ((and (assoc-ref opts 'roll-back?) (not dry-run?)) + (begin + (roll-back profile) + (process-actions (alist-delete 'roll-back? opts)))) + ((and (assoc-ref opts 'delete-generations) + (not dry-run?)) + (filter-map (match-lambda + (('delete-generations . pattern) + (begin (apply-to-generations delete-generation + profile pattern) + (process-actions + (alist-delete 'delete-generations opts)))) + (_ #f)) + opts)) + (else + (let* ((installed (manifest-packages (profile-manifest profile)= )) + (upgrade-regexps (filter-map (match-lambda + (('upgrade . regexp) + (make-regexp (or regexp "= "))) + (_ #f)) + opts)) + (upgrade (if (null? upgrade-regexps) + '() + (let ((newest (find-newest-available-packag= es))) + (filter-map + (match-lambda + ((name version output path _) + (and (any (cut regexp-exec <> name) + upgrade-regexps) + (upgradeable? name version path) + (find-package name + (or output "out")))) + (_ #f)) + installed)))) + (install (append + upgrade + (filter-map (match-lambda + (('install . (? package? p)) + (package->tuple p)) + (('install . (? store-path?)) + #f) + (('install . package) + (find-package package)) + (_ #f)) + opts))) + (drv (filter-map (match-lambda + ((name version sub-drv + (? package? package) + (deps ...)) + (check-package-freshness package) + (package-derivation (%store) package)) + (_ #f)) + install)) + (install* + (append + (filter-map (match-lambda + (('install . (? package? p)) + #f) + (('install . (? store-path? path)) + (let-values (((name version) + (package-name->name+version + (store-path-package-name + path)))) + `(,name ,version #f ,path ()))) + (_ #f)) + opts) + (map (lambda (tuple drv) + (match tuple + ((name version sub-drv _ (deps ...)) + (let ((output-path + (derivation->output-path + drv sub-drv))) + `(,name ,version ,sub-drv ,output-path + ,(canonicalize-deps deps)))))) + install drv))) + (remove (filter-map (match-lambda + (('remove . package) + package) (_ #f)) =2D opts) =2D (map (lambda (tuple drv) =2D (match tuple =2D ((name version sub-drv _ (deps ...)) =2D (let ((output-path =2D (derivation->output-path =2D drv sub-drv))) =2D `(,name ,version ,sub-drv ,output-= path =2D ,(canonicalize-deps deps))= )))) =2D install drv))) =2D (remove (filter-map (match-lambda =2D (('remove . package) =2D package) =2D (_ #f)) =2D opts)) =2D (remove* (filter-map (cut assoc <> installed) remove)) =2D (packages (append install* =2D (fold (lambda (package result) =2D (match package =2D ((name _ out _ ...) =2D (filter (negate =2D (cut same-package? = <> =2D name out)) =2D result)))) =2D (fold alist-delete installed remo= ve) =2D install*)))) + opts)) + (remove* (filter-map (cut assoc <> installed) remove)) + (packages + (append install* + (fold (lambda (package result) + (match package + ((name _ out _ ...) + (filter (negate + (cut same-package? <> + name out)) + result)))) + (fold alist-delete installed remove) + install*)))) =20 (when (equal? profile %current-profile) (ensure-default-profile)) @@ -946,7 +1014,7 @@ more information.~%")) count) count) (display-search-paths packages =2D profile)))))))))) + profile))))))))))) =20 (define (process-query opts) ;; Process any query specified by OPTS. Return #t when a query was @@ -970,18 +1038,7 @@ more information.~%")) (format #f "~a-~a-link" profile number)))) (newline))) =20 =2D (cond ((not (file-exists? profile)) ; XXX: race condition =2D (leave (_ "profile '~a' does not exist~%") =2D profile)) =2D ((string-null? pattern) =2D (for-each list-generation =2D (generation-numbers profile))) =2D ((matching-generations pattern profile) =2D =3D> =2D (cut for-each list-generation <>)) =2D (else =2D (leave (_ "invalid syntax: ~a~%") =2D pattern))) + (apply-to-generations list-generation profile pattern) #t) =20 (('list-installed regexp) diff --git a/tests/guix-package.sh b/tests/guix-package.sh index b09a9c0..65bc94c 100644 =2D-- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -132,6 +132,13 @@ then # Make sure LIBRARY_PATH gets listed by `--search-paths'. guix package --bootstrap -p "$profile" -i guile-bootstrap -i gcc-boots= trap guix package --search-paths -p "$profile" | grep LIBRARY_PATH + + # Delete the third generation and check that it was actually deleted. + guix package -p "$profile" --delete-generations=3D3 + test -z "`guix package -p "$profile" -l 3`" + + # Do not output anything when such a generation does not exist. + test -z "`guix package -p "$profile" --delete-generations=3D42`" fi =20 # Make sure the `:' syntax works. =2D-=20 1.7.9.5 --=-=-=-- --==-=-= Content-Type: application/pgp-signature -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.10 (GNU/Linux) iQIcBAEBAgAGBQJSP0K0AAoJEM+IQzI9IQ38ic8P/A8j0fV6lcbmPy02FV6hrZJo ux1qznfLLonIanf9rYumsYo9p+oNl43VZ2fSBK2+jyalqOjmTCrQ9Rb3gCm0z3nn XpWhuJdalnevkIBSnSPXpwHwurqIbWq8XfJjLNUHCAlC0Yp9HcImlcIUCDJyrDYO 2XNZuBub0N2KN89Ytky5EJyBOKuw8AngJSEJOoBE/dnJmtm77TEGceqFuSo4nw3d 59+eToiuSZtyCbxs7wzaumwrXCI2zNaaOL0kIzI8jRffvb6R+rHkepV8BecwW8TQ O+eOILOCZCCvYEPM7YM2gvAY0XYclgkvqTFodieBF5VtiJKoQ2IkcJswGkB7Htfg vqUqAXQBXjfHLIM5U46wOidZv0p1n1H/wSe/FxSw9DWix73qCFwhXe5PtSuHwRVM 5V7bbJKuGSxrIGEhSwBNi89TNHN2tfaDp54t1JkKMV1CMKdSfIviKP8bac8lJpcN cMJTRJG8PhPg4IKB8qhe6y4deZ0jgLb2TrQW1Z3xtEsb3Bkz5fMiRRZzXQpo6as2 OlX7I55yj6Q3Zu6skYBHtp00zJ19zJqMN+0TvwGrrT+z8jgeBichVc1lN84ljHrt xuMkwGyZ1yLwJVPbTt60fFUo5tRhiPfnw3ucF/tdsGGtKH5UWzSVeJYlSEpgyMSM vHbgIyvV7SuxQQcI2E5i =A5ed -----END PGP SIGNATURE----- --==-=-=--