From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp1 ([2001:41d0:8:6d80::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms0.migadu.com with LMTPS id IIexFTj5LWGbnQAAgWs5BA (envelope-from ) for ; Tue, 31 Aug 2021 11:41:12 +0200 Received: from aspmx1.migadu.com ([2001:41d0:8:6d80::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp1 with LMTPS id eI0RETj5LWF3XAAAbx9fmQ (envelope-from ) for ; Tue, 31 Aug 2021 09:41:12 +0000 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 94D371AA11 for ; Tue, 31 Aug 2021 11:41:11 +0200 (CEST) Received: from localhost ([::1]:53270 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1mL0GU-000467-KL for larch@yhetil.org; Tue, 31 Aug 2021 05:41:10 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:47684) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mL0GL-00045n-U6 for guix-patches@gnu.org; Tue, 31 Aug 2021 05:41:01 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:49724) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1mL0GL-0002F4-MM for guix-patches@gnu.org; Tue, 31 Aug 2021 05:41:01 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1mL0GL-0002J5-KO for guix-patches@gnu.org; Tue, 31 Aug 2021 05:41:01 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#50296] [PATCH 1/2] scripts: Add 'guix home'. Resent-From: Andrew Tropin Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 31 Aug 2021 09:41:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 50296 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 50296@debbugs.gnu.org Received: via spool by 50296-submit@debbugs.gnu.org id=B50296.16304028258816 (code B ref 50296); Tue, 31 Aug 2021 09:41:01 +0000 Received: (at 50296) by debbugs.gnu.org; 31 Aug 2021 09:40:25 +0000 Received: from localhost ([127.0.0.1]:33037 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mL0Fh-0002I5-LF for submit@debbugs.gnu.org; Tue, 31 Aug 2021 05:40:25 -0400 Received: from mail-lj1-f178.google.com ([209.85.208.178]:46651) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mL0Fe-0002Hk-HA for 50296@debbugs.gnu.org; Tue, 31 Aug 2021 05:40:20 -0400 Received: by mail-lj1-f178.google.com with SMTP id w4so30587269ljh.13 for <50296@debbugs.gnu.org>; Tue, 31 Aug 2021 02:40:18 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=trop-in.20150623.gappssmtp.com; s=20150623; h=from:to:subject:in-reply-to:references:date:message-id:mime-version; bh=eRT8tu2JMXfXmCkZMx8xGCJYjVQCMHKC54rb79kNExs=; b=LCj2vfIFzE3DM3PaKU0gQjBVVZK/ehEhwWGgkGHqoXn5j/8WlJMhlrYrk0VlY58fYz Hhkqe9KPFFPBww+hxVxDha6Tva0/HxmX4yMn+xbvj3Dsox+xcGQXiitkqGPFkvtaWYxj Ha2TWXQ5oCctbDItHmTO2hFqGqbhmIm2dHQmX8cl5oe2drWq6vyfZHrGWfYdXEitaASZ PF5z2bvspCDevG4P84C97SaMmI55rhu6oAAIa7lsRzKKWJ2Yq6cIE2cReyf4KZWTRdHQ n/c1FoCz3HZic5fv+ucOqK8djyZuE8i9vmfIbNhAxNy0tMRYlAqMjMgGxvg0JZ78mt+Z 2H3w== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:from:to:subject:in-reply-to:references:date :message-id:mime-version; bh=eRT8tu2JMXfXmCkZMx8xGCJYjVQCMHKC54rb79kNExs=; b=cBA8yjEbJTvhu9xXl6Cw/adtcf4+vqM105OrTdX8tWCSiEelSpjcQ9UTenBDyEHVTK 7wvZVMyZoiWV/KkOpLxPcg99RIeK5kujeN3nibXVhuILkhF92Y3vtUJo+3eB95Xe/SEF FHBWjem8AnOaDbQJBT8SoKCq74BSsDHadS3fkw78tpE9aB9TmgTjkZ9PMpZUAUA2BX78 ypxajB9BfHx+1ijJ9gLYD8v7g9YHgRrpXPp5psy4yMNyckjHTJKF2UOmx5UewJFAU85A R4o9ERi2o9X+5oyO4folueieebpYvWU4ToC+v9yG0g+0ANRiNHeT2JAs4fY9MfIs4lf3 +yUQ== X-Gm-Message-State: AOAM531ul+Sp1SzERX0KqjialxASdP6kyjSF2gSrkXwWUyvxfOuzM30E PgY8IyBOi0kuNtbRwZDxL3X/8g6JOV4dhA== X-Google-Smtp-Source: ABdhPJyAktXnAS80GfBqcWMG3SqrmJjH2Ti2AVuVa49RzsubhhSrebK2KktPxs6ZP79kuecXw5JJZw== X-Received: by 2002:a2e:bb93:: with SMTP id y19mr23632939lje.79.1630402811748; Tue, 31 Aug 2021 02:40:11 -0700 (PDT) Received: from localhost (109-252-93-92.nat.spd-mgts.ru. [109.252.93.92]) by smtp.gmail.com with ESMTPSA id d4sm1675947lfg.178.2021.08.31.02.40.10 for <50296@debbugs.gnu.org> (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 31 Aug 2021 02:40:11 -0700 (PDT) From: Andrew Tropin In-Reply-To: References: <874kb6j718.fsf@trop.in> Date: Tue, 31 Aug 2021 12:40:08 +0300 Message-ID: <87y28ihs07.fsf@trop.in> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: "Guix-patches" X-Migadu-Flow: FLOW_IN ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1630402871; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:mime-version:mime-version: content-type:content-type:resent-cc:resent-from:resent-sender: resent-message-id:in-reply-to:in-reply-to:references:references: list-id:list-help:list-unsubscribe:list-subscribe:list-post: dkim-signature; bh=ewCXRqBvx350R2BynD/rYsCiRL4sn9kuMiJ35yQzjic=; b=Z6Yk4Y0AeGprHPu1mKHZE+CB3bqaYPfJ75mV1KjC0Y9q4OLCx8Zt8rjnnNRtBSxfZkC9Zn 785VxRC+Ocy741XxWeCE0M+4ff6WZyTkLvbW3VA8BZA65y8qFnZaEtAeFJeuE15OM24BRO QpzWLmR+9XROfjbqMsye9d2ZhC5bAEnX+ONzu30GtzufUOQmtUFP+dTtRjQQBsvPDTLAfz 7htrXcx7a0Wmq/EpaI5RpVnpe32O7FI5L27n/bNvTtceNJkL7ZAKWruRLTOQ8wmJWKDHGo w7ZEuErgA5r3nUKgS2/DSVU8U0DaGZAQ0+JZcz5ZEdD8e1ruDYp6dhvrTGyxbg== ARC-Seal: i=1; s=key1; d=yhetil.org; t=1630402871; a=rsa-sha256; cv=none; b=TezE55QafuGL+oylh1fByHoiXy26yg1GWBeOtTDvOvQcoKgL9O64v3zaK+t6DqXQFu8X1g 52IXHIGqOrZCg/+i2VPXjdBOE0b6GC7HoP/M1FLxW8ZtMHlwofTY8W/q1UTnrSy/PR7nop lTuMSmziFjfhVimLBnPxK4jnwGG7I0pAo/U4F/bI6ElyKl/qDyQMGUkkrS5RnzNKSOMbRk D54HNRXGCn+zV+ZhVkgdjV8PmfZ8BLeYRECCKSN9WwoPzM3Nm00aNnVNalxwVrqXb/mApR PcRLtu7IDso2gyumdvSG2d95cl2Ha+17xYuEClaUrwja/oKmvOhABv+dRob+pQ== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=trop-in.20150623.gappssmtp.com header.s=20150623 header.b=LCj2vfIF; dmarc=none; spf=pass (aspmx1.migadu.com: domain of guix-patches-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=guix-patches-bounces@gnu.org X-Migadu-Spam-Score: -3.52 Authentication-Results: aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=trop-in.20150623.gappssmtp.com header.s=20150623 header.b=LCj2vfIF; dmarc=none; spf=pass (aspmx1.migadu.com: domain of guix-patches-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=guix-patches-bounces@gnu.org X-Migadu-Queue-Id: 94D371AA11 X-Spam-Score: -3.52 X-Migadu-Scanner: scn0.migadu.com X-TUID: l61GgCg2puUO --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable * guix/scripts/home.scm: New file. * Makefile.am (MODULES): Add it. =2D-- Makefile.am | 2 + guix/scripts/home.scm | 512 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 514 insertions(+) create mode 100644 guix/scripts/home.scm diff --git a/Makefile.am b/Makefile.am index 327d3f9961..d44360c034 100644 =2D-- a/Makefile.am +++ b/Makefile.am @@ -15,6 +15,7 @@ # Copyright =C2=A9 2018 Alex Vong # Copyright =C2=A9 2019 Efraim Flashner # Copyright =C2=A9 2021 Chris Marusich +# Copyright =C2=A9 2021 Andrew Tropin # # This file is part of GNU Guix. # @@ -294,6 +295,7 @@ MODULES =3D \ guix/scripts/system.scm \ guix/scripts/system/search.scm \ guix/scripts/system/reconfigure.scm \ + guix/scripts/home.scm \ guix/scripts/lint.scm \ guix/scripts/challenge.scm \ guix/scripts/import/crate.scm \ diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm new file mode 100644 index 0000000000..9eb5c0c917 =2D-- /dev/null +++ b/guix/scripts/home.scm @@ -0,0 +1,512 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright =C2=A9 2021 Andrew Tropin +;;; Copyright =C2=A9 2021 Xinglu Chen +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix scripts home) + #:use-module (gnu packages admin) + #:use-module ((gnu services) #:hide (delete)) + #:use-module (gnu packages) + #:use-module (gnu home) + #:use-module (gnu home-services) + #:use-module (guix channels) + #:use-module (guix derivations) + #:use-module (guix ui) + #:use-module (guix grafts) + #:use-module (guix packages) + #:use-module (guix profiles) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix scripts package) + #:use-module (guix scripts build) + #:use-module (guix scripts system search) + #:autoload (guix scripts pull) (channel-commit-hyperlink) + ;; #:use-module (guix scripts home import) + #:use-module ((guix status) #:select (with-status-verbosity)) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) + #:use-module (srfi srfi-37) + #:use-module (ice-9 match) + #:export (guix-home)) + + +;;; +;;; Options. +;;; + +(define %user-module + (make-user-module '((gnu home)))) + +(define %guix-home + (string-append %profile-directory "/guix-home")) + +(define (show-help) + (display (G_ "Usage: guix home [OPTION ...] ACTION [ARG ...] [FILE] +Build the home environment declared in FILE according to ACTION. +Some ACTIONS support additional ARGS.\n")) + (newline) + (display (G_ "The valid values for ACTION are:\n")) + (newline) + (display (G_ "\ + search search for existing service types\n")) + (display (G_ "\ + reconfigure switch to a new home environment configuration\n")) + (display (G_ "\ + roll-back switch to the previous home environment configuratio= n\n")) + (display (G_ "\ + describe describe the current home environment\n")) + (display (G_ "\ + list-generations list the home environment generations\n")) + (display (G_ "\ + switch-generation switch to an existing home environment configuration= \n")) + (display (G_ "\ + delete-generations delete old home environment generations\n")) + (display (G_ "\ + build build the home environment without installing anythi= ng\n")) + (display (G_ "\ + import generates a home environment definition from dotfile= s\n")) + + (show-build-options-help) + (display (G_ " + -v, --verbosity=3DLEVEL use the given verbosity LEVEL")) + (newline) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define (verbosity-level opts) + "Return the verbosity level based on OPTS, the alist of parsed options." + (or (assoc-ref opts 'verbosity) + (if (eq? (assoc-ref opts 'action) 'build) + 2 1))) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix show"))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) + %standard-build-options)) + +(define %default-options + `((build-mode . ,(build-mode normal)) + (graft? . #t) + (substitutes? . #t) + (offload? . #t) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) + (verbosity . 3) + (debug . 0))) + + +;;; +;;; Actions. +;;; + +(define* (perform-action action he + #:key + dry-run? + derivations-only? + use-substitutes?) + "Perform ACTION for home environment. " + + (define println + (cut format #t "~a~%" <>)) + + (mlet* %store-monad + ((he-drv (home-environment-derivation he)) + (drvs (mapm/accumulate-builds lower-object (list he-drv))) + (% (if derivations-only? + (return + (for-each (compose println derivation-file-name) drv= s)) + (built-derivations drvs))) + + (he-out-path -> (derivation->output-path he-drv))) + (if (or dry-run? derivations-only?) + (return #f) + (begin + (for-each (compose println derivation->output-path) drvs) + + (case action + ((reconfigure) + (let* ((number (generation-number %guix-home)) + (generation (generation-file-name + %guix-home (+ 1 number)))) + + (switch-symlinks generation he-out-path) + (switch-symlinks %guix-home generation) + (setenv "GUIX_NEW_HOME" he-out-path) + (primitive-load (string-append he-out-path "/activate")) + (setenv "GUIX_NEW_HOME" #f) + (return he-out-path))) + (else + (newline) + (return he-out-path))))))) + +(define (process-action action args opts) + "Process ACTION, a sub-command, with the arguments are listed in ARGS. +ACTION must be one of the sub-commands that takes a home environment +declaration as an argument (a file name.) OPTS is the raw alist of options +resulting from command-line parsing." + (define (ensure-home-environment file-or-exp obj) + (unless (home-environment? obj) + (leave (G_ "'~a' does not return a home environment ~%") + file-or-exp)) + obj) + + (let* ((file (match args + (() #f) + ((x . _) x))) + (expr (assoc-ref opts 'expression)) + (system (assoc-ref opts 'system)) + + (transform (lambda (obj) + (home-environment-with-provenance obj file))) + + (home-environment + (transform + (ensure-home-environment + (or file expr) + (cond + ((and expr file) + (leave + (G_ "both file and expression cannot be specified~%"))) + (expr + (read/eval expr)) + (file + (load* file %user-module + #:on-error (assoc-ref opts 'on-error))) + (else + (leave (G_ "no configuration specified~%"))))))) + + (dry? (assoc-ref opts 'dry-run?))) + + (with-store store + (set-build-options-from-command-line store opts) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:verbosity + (verbosity-level opts) + #:dry-run? + (assoc-ref opts 'dry-run?)) + + (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + + (case action + (else + (perform-action action home-environment + #:dry-run? dry? + #:derivations-only? (assoc-ref opts 'deriva= tions-only?) + #:use-substitutes? (assoc-ref opts 'substit= utes?)) + )))))) + (warn-about-disk-space))) + + +(define (process-command command args opts) + "Process COMMAND, one of the 'guix home' sub-commands. ARGS is its +argument list and OPTS is the option alist." + (define-syntax-rule (with-store* store exp ...) + (with-store store + (set-build-options-from-command-line store opts) + exp ...)) + (case command + ;; The following commands do not need to use the store, and they do no= t need + ;; an home environment file. + ((search) + (apply search args)) + ((import) + (let* ((profiles (delete-duplicates + (match (filter-map (match-lambda + (('profile . p) p) + (_ #f)) + opts) + (() (list %current-profile)) + (lst (reverse lst))))) + (manifest (concatenate-manifests + (map profile-manifest profiles)))) + (import-manifest manifest (current-output-port)))) + ((describe) + (match (generation-number %guix-home) + (0 + (error (G_ "no home environment generation, nothing to describe~%"= ))) + (generation + (display-home-environment-generation generation)))) + ((list-generations) + (let ((pattern (match args + (() #f) + ((pattern) pattern) + (x (leave (G_ "wrong number of arguments~%")))))) + (list-generations pattern))) + ((switch-generation) + (let ((pattern (match args + ((pattern) pattern) + (x (leave (G_ "wrong number of arguments~%")))))) + (with-store* store + (switch-to-home-environment-generation store pattern))= )) + ((roll-back) + (let ((pattern (match args + (() "") + (x (leave (G_ "wrong number of arguments~%")))))) + (with-store* store + (roll-back-home-environment store)))) + ((delete-generations) + (let ((pattern (match args + (() #f) + ((pattern) pattern) + (x (leave (G_ "wrong number of arguments~%")))))) + (with-store* + store + (delete-matching-generations store %guix-home pattern)))) + (else (process-action command args opts)))) + +(define-command (guix-home . args) + (synopsis "build and deploy home environments") + + (define (parse-sub-command arg result) + ;; Parse sub-command ARG and augment RESULT accordingly. + (if (assoc-ref result 'action) + (alist-cons 'argument arg result) + (let ((action (string->symbol arg))) + (case action + ((build + reconfigure + extension-graph shepherd-graph + list-generations describe + delete-generations roll-back + switch-generation search + import) + (alist-cons 'action action result)) + (else (leave (G_ "~a: unknown action~%") action)))))) + + (define (match-pair car) + ;; Return a procedure that matches a pair with CAR. + (match-lambda + ((head . tail) + (and (eq? car head) tail)) + (_ #f))) + + (define (option-arguments opts) + ;; Extract the plain arguments from OPTS. + (let* ((args (reverse (filter-map (match-pair 'argument) opts))) + (count (length args)) + (action (assoc-ref opts 'action)) + (expr (assoc-ref opts 'expression))) + (define (fail) + (leave (G_ "wrong number of arguments for action '~a'~%") + action)) + + (unless action + (format (current-error-port) + (G_ "guix home: missing command name~%")) + (format (current-error-port) + (G_ "Try 'guix home --help' for more information.~%")) + (exit 1)) + + (case action + ((build reconfigure) + (unless (or (=3D count 1) + (and expr (=3D count 0))) + (fail))) + ((init) + (unless (=3D count 2) + (fail)))) + args)) + + (with-error-handling + (let* ((opts (parse-command-line args %options + (list %default-options) + #:argument-handler + parse-sub-command)) + (args (option-arguments opts)) + (command (assoc-ref opts 'action))) + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (with-status-verbosity (verbosity-level opts) + (process-command command args opts)))))) + + +;;; +;;; Searching. +;;; + +(define service-type-name* + (compose symbol->string service-type-name)) + +(define (service-type-description-string type) + "Return the rendered and localised description of TYPE, a service type." + (and=3D> (service-type-description type) + (compose texi->plain-text P_))) + +(define %service-type-metrics + ;; Metrics used to estimate the relevance of a search result. + `((,service-type-name* . 3) + (,service-type-description-string . 2) + (,(lambda (type) + (match (and=3D> (service-type-location type) location-file) + ((? string? file) + (basename file ".scm")) + (#f + ""))) + . 1))) + +(define (find-service-types regexps) + "Return a list of service type/score pairs: service types whose name or +description matches REGEXPS sorted by relevance, and their score." + (let ((matches (fold-home-service-types + (lambda (type result) + (match (relevance type regexps + %service-type-metrics) + ((? zero?) + result) + (score + (cons (cons type score) result)))) + '()))) + (sort matches + (lambda (m1 m2) + (match m1 + ((type1 . score1) + (match m2 + ((type2 . score2) + (if (=3D score1 score2) + (string>? (service-type-name* type1) + (service-type-name* type2)) + (> score1 score2)))))))))) + +(define (search . args) + (with-error-handling + (let* ((regexps (map (cut make-regexp* <> regexp/icase) args)) + (matches (find-service-types regexps))) + (leave-on-EPIPE + (display-search-results matches (current-output-port) + #:print service-type->recutils + #:command "guix home search"))))) + + +;;; +;;; Generations. +;;; + +(define* (display-home-environment-generation + number + #:optional (profile %guix-home)) + "Display a summary of home-environment generation NUMBER in a +human-readable format." + (define (display-channel channel) + (format #t " ~a:~%" (channel-name channel)) + (format #t (G_ " repository URL: ~a~%") (channel-url channel)) + (when (channel-branch channel) + (format #t (G_ " branch: ~a~%") (channel-branch channel))) + (format #t (G_ " commit: ~a~%") + (if (supports-hyperlinks?) + (channel-commit-hyperlink channel) + (channel-commit channel)))) + + (unless (zero? number) + (let* ((generation (generation-file-name profile number))) + (define-values (channels config-file) + ;; The function will work for home environments too, we just + ;; need to keep provenance file. + (system-provenance generation)) + + (display-generation profile number) + (format #t (G_ " file name: ~a~%") generation) + (format #t (G_ " canonical file name: ~a~%") (readlink* generation)) + ;; TRANSLATORS: Please preserve the two-space indentation. + + (unless (null? channels) + ;; TRANSLATORS: Here "channel" is the same terminology as used in + ;; "guix describe" and "guix pull --channels". + (format #t (G_ " channels:~%")) + (for-each display-channel channels)) + (when config-file + (format #t (G_ " configuration file: ~a~%") + (if (supports-hyperlinks?) + (file-hyperlink config-file) + config-file)))))) + +(define* (list-generations pattern #:optional (profile %guix-home)) + "Display in a human-readable format all the home environment +generations matching PATTERN, a string. When PATTERN is #f, display +all the home environment generations." + (cond ((not (file-exists? profile)) ; XXX: race condition + (raise (condition (&profile-not-found-error + (profile profile))))) + ((not pattern) + (for-each display-home-environment-generation (profile-generation= s profile))) + ((matching-generations pattern profile) + =3D> + (lambda (numbers) + (if (null-list? numbers) + (exit 1) + (leave-on-EPIPE + (for-each display-home-environment-generation numbers)))))= )) + + +;;; +;;; Switch generations. +;;; + +;; TODO: Make it public in (guix scripts system) +(define-syntax-rule (unless-file-not-found exp) + (catch 'system-error + (lambda () + exp) + (lambda args + (if (=3D ENOENT (system-error-errno args)) + #f + (apply throw args))))) + +(define (switch-to-home-environment-generation store spec) + "Switch the home-environment profile to the generation specified by +SPEC. STORE is an open connection to the store." + (let* ((number (relative-generation-spec->number %guix-home spec)) + (generation (generation-file-name %guix-home number)) + (activate (string-append generation "/activate"))) + (if number + (begin + (setenv "GUIX_NEW_HOME" (readlink generation)) + (switch-to-generation* %guix-home number) + (unless-file-not-found (primitive-load activate)) + (setenv "GUIX_NEW_HOME" #f)) + (leave (G_ "cannot switch to home environment generation '~a'~%") = spec)))) + + +;;; +;;; Roll-back. +;;; + +(define (roll-back-home-environment store) + "Roll back the home-environment profile to its previous generation. +STORE is an open connection to the store." + (switch-to-home-environment-generation store "-1")) =2D-=20 2.33.0 --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQIzBAEBCgAdFiEEKEGaxlA4dEDH6S/6IgjSCVjB3rAFAmEt+PgACgkQIgjSCVjB 3rAkUw/+LZ1Cq3n46PxPfj6V9zXKZxyzU4k4MHTq5o75G2PPgLDjwi9tst/Nz7T5 Reo3ETe/FfsVWWTl8Fi4lzUk+uIorREnwcKwLqwJP2H0vxXC6LcfLswb6TpVKGq5 fBAyfPHbeBFZiKlfpKdPaHKsXcqM50zsoi7UcGpYcJDnUaVBfxAqfjT71Ru/N8K4 hcmepyths+s23+iqXMM97u+aKWIxTtPnksmZVHeDLVSDjaBmjFa6DP5CsfP+kinJ rPH1sPaVUuRbLAYMhcQVOTjGrKeTAEOG2ZG9jgZJrUbsYZdndrH3WqjleTvAM6Ln 3O/IlFeIKZ8UHxeDL78ZVldqMNJt4yY69jR/rTYu13DFdvRCnPIgu765ddDZ5+TB +5AlHSWUaRMWHi6KKjOoAKWGDthu3KHiioIX9Y/FpvGSBzqFkdrKCEMUVG9m6yyK 4PkKGd255/w8WwFxIUyUPGrOr7CekCDO+uBdyFtMvgThBLk/plgRi6JhfkJLha3Z Pd8h5Hl8u170mRJHTedOr8tfVIwaXJpEVD6NMxobiD7HyXEsV/elI3UIrHnholK5 589dYqIFDr3EU5/1hxViWlXyQzUHO+EI84nntQLdVjuJAaMZCS3exNLqfOrWr+2G Wr7MguyydHYZiY5eU2sd8JV7KeIiTiqLCgjnJZ8ATSKWyip3ce0= =WPvF -----END PGP SIGNATURE----- --=-=-=--