From patchwork Tue Aug 31 09:40:08 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Andrew Tropin X-Patchwork-Id: 32440 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id A17A327BBE3; Tue, 31 Aug 2021 10:41:11 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.8 required=5.0 tests=BAYES_00,DKIM_SIGNED, MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H2,SPF_HELO_PASS,T_DKIM_INVALID, URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 92B5D27BBE1 for ; Tue, 31 Aug 2021 10:41:10 +0100 (BST) Received: from localhost ([::1]:53270 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1mL0GT-000467-O6 for patchwork@mira.cbaines.net; Tue, 31 Aug 2021 05:41:09 -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 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+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/scripts/home.scm: New file. * Makefile.am (MODULES): Add it. --- 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 --- a/Makefile.am +++ b/Makefile.am @@ -15,6 +15,7 @@ # Copyright © 2018 Alex Vong # Copyright © 2019 Efraim Flashner # Copyright © 2021 Chris Marusich +# Copyright © 2021 Andrew Tropin # # This file is part of GNU Guix. # @@ -294,6 +295,7 @@ MODULES = \ 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 --- /dev/null +++ b/guix/scripts/home.scm @@ -0,0 +1,512 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Andrew Tropin +;;; Copyright © 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 configuration\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 anything\n")) + (display (G_ "\ + import generates a home environment definition from dotfiles\n")) + + (show-build-options-help) + (display (G_ " + -v, --verbosity=LEVEL 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) drvs)) + (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 'derivations-only?) + #:use-substitutes? (assoc-ref opts 'substitutes?)) + )))))) + (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 not 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 (= count 1) + (and expr (= count 0))) + (fail))) + ((init) + (unless (= 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=> (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=> (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 (= 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-generations profile))) + ((matching-generations pattern profile) + => + (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 (= 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")) From patchwork Tue Aug 31 09:40:58 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Andrew Tropin X-Patchwork-Id: 32441 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 1E13527BBE3; Tue, 31 Aug 2021 10:42:13 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.8 required=5.0 tests=BAYES_00,DKIM_SIGNED, MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H2,SPF_HELO_PASS,T_DKIM_INVALID, URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 5F35927BBE1 for ; Tue, 31 Aug 2021 10:42:12 +0100 (BST) Received: from localhost ([::1]:53614 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1mL0HT-0004RP-G4 for patchwork@mira.cbaines.net; Tue, 31 Aug 2021 05:42:11 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:48036) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mL0HK-0004Pw-Kw for guix-patches@gnu.org; Tue, 31 Aug 2021 05:42:02 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:49736) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1mL0HK-000399-Cx for guix-patches@gnu.org; Tue, 31 Aug 2021 05:42:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1mL0HK-0002LD-BW for guix-patches@gnu.org; Tue, 31 Aug 2021 05:42:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#50296] [PATCH 2/2] scripts: home: Add import subcommand. Resent-From: Andrew Tropin Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 31 Aug 2021 09:42:02 +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.16304028718915 (code B ref 50296); Tue, 31 Aug 2021 09:42:02 +0000 Received: (at 50296) by debbugs.gnu.org; 31 Aug 2021 09:41:11 +0000 Received: from localhost ([127.0.0.1]:33043 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mL0GV-0002Jd-5O for submit@debbugs.gnu.org; Tue, 31 Aug 2021 05:41:11 -0400 Received: from mail-lf1-f41.google.com ([209.85.167.41]:43964) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mL0GS-0002JO-Ay for 50296@debbugs.gnu.org; Tue, 31 Aug 2021 05:41:09 -0400 Received: by mail-lf1-f41.google.com with SMTP id m18so23039833lfl.10 for <50296@debbugs.gnu.org>; Tue, 31 Aug 2021 02:41:08 -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=d9QqO7l7uQhCJWojmGtT0Y22Y+xH6QxS41I9BWfDuPM=; b=BU98cVPhZXrLcsf6+Qbc/TKsxsF8ESMD5ivCblJkTqrxcx17RPFTDLOW13yt1ijZql pHWjweUioSvGU+NjoF9ed4G+IiKgMmgIIMjONciOQEy+VBqGrdXDxcqw115KzlEgy+7R CddpbqyFhNwUpAHm81fpGwppPcr9tydTHOm8TYYNg2UjLyCNWpaMhzKdKR4pVyj/VxeR 7Wrq8U1MZksvby7EQXCcVY3yA5Ri9AOjOrU/QyvUbnp9Lm4Lm2MMbQxcn0BEOSAEO2np 43DigNsyYkhgv/M/ZTWKCRPLj/EEZkD9JWv8Oo/36knjhTnTe6aMSyEidp/vH5gu8gxF qCYg== 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=d9QqO7l7uQhCJWojmGtT0Y22Y+xH6QxS41I9BWfDuPM=; b=FeYmqHrfAx81pue3Mxd3KLaBEN09nuChd4HR9PwHfGBRgyGKWYcbU3Hg/E1lna3eC5 yMZrOJPGmNHzbzukHkrdhtmjliHtZBToxdrPyH2XgdJAtmFJ5OdrO6oGjMZ/VUb5SnXq D7MQV2kiNd0+DGG1egkJ/ReNVnrKtVFGDJdfwPWzZ3kZA/kg9UFboqR9DlKs7+M1Xoc4 MsCz9a4gYxjh4+pk4fLl4ydKXje5S5J+ivjEk8oXtEqlAzx9QJwjZHsZRQfWdJhwriaw 7jCoOCu0jHcUOJ1BKRe6dQALFKsbGB0OUnkmyryivKzZVhS3bcaWBAJ0rJbRQwnR2gUs 30nw== X-Gm-Message-State: AOAM532CcuPk4d8e0f9o6yDuVqgCMy8FfGWNFUuRMfqrvtiwmD038A/L BK/OhSAMao9sLvYD4OjcPZxJNhdPBdIeMw== X-Google-Smtp-Source: ABdhPJzPM7QZNAmf5gYtQ7biYjcRhOVdXNN3ww+MGr8OBDfCjY9/wcvu0q35RkSA/k8m9tCCV83cGA== X-Received: by 2002:a05:6512:11ec:: with SMTP id p12mr20613626lfs.379.1630402861788; Tue, 31 Aug 2021 02:41:01 -0700 (PDT) Received: from localhost (109-252-93-92.nat.spd-mgts.ru. [109.252.93.92]) by smtp.gmail.com with ESMTPSA id w2sm1312226lfq.20.2021.08.31.02.41.00 for <50296@debbugs.gnu.org> (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 31 Aug 2021 02:41:01 -0700 (PDT) From: Andrew Tropin In-Reply-To: References: <874kb6j718.fsf@trop.in> Date: Tue, 31 Aug 2021 12:40:58 +0300 Message-ID: <87v93mhryt.fsf@trop.in> MIME-Version: 1.0 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+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * guix/scripts/home/import.scm: New file. * Makefile.am (MODULES): Add it. --- Makefile.am | 1 + guix/scripts/home.scm | 2 +- guix/scripts/home/import.scm | 241 +++++++++++++++++++++++++++++++++++ 3 files changed, 243 insertions(+), 1 deletion(-) create mode 100644 guix/scripts/home/import.scm diff --git a/Makefile.am b/Makefile.am index d44360c034..c27dcf9a38 100644 --- a/Makefile.am +++ b/Makefile.am @@ -296,6 +296,7 @@ MODULES = \ guix/scripts/system/search.scm \ guix/scripts/system/reconfigure.scm \ guix/scripts/home.scm \ + guix/scripts/home/import.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 index 9eb5c0c917..75df6d707d 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -36,7 +36,7 @@ #: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 scripts home import) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix gexp) #:use-module (guix monads) diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm new file mode 100644 index 0000000000..39f45dbeac --- /dev/null +++ b/guix/scripts/home/import.scm @@ -0,0 +1,241 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Xinglu Chen +;;; Copyright © 2021 Andrew Tropin +;;; +;;; 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 import) + #:use-module (guix profiles) + #:use-module (guix ui) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (srfi srfi-1) + #:export (import-manifest)) + +;;; Commentary: +;;; +;;; This module provides utilities for generating home service +;;; configurations from existing "dotfiles". +;;; +;;; Code: + + +(define (generate-bash-module+configuration) + (let ((rc (string-append (getenv "HOME") "/.bashrc")) + (profile (string-append (getenv "HOME") "/.bash_profile")) + (logout (string-append (getenv "HOME") "/.bash_logout"))) + `((gnu home-services bash) + (service home-bash-service-type + (home-bash-configuration + ,@(if (file-exists? rc) + `((bashrc + (list (slurp-file-gexp (local-file ,rc))))) + '()) + ,@(if (file-exists? profile) + `((bash-profile + (list (slurp-file-gexp + (local-file ,profile))))) + '()) + ,@(if (file-exists? logout) + `((bash-logout + (list (slurp-file-gexp + (local-file ,logout))))) + '())))))) + + +(define %files-configurations-alist + `((".bashrc" . ,generate-bash-module+configuration) + (".bash_profile" . ,generate-bash-module+configuration) + (".bash_logout" . ,generate-bash-module+configuration))) + +(define (modules+configurations) + (let ((configurations (delete-duplicates + (filter-map (match-lambda + ((file . proc) + (if (file-exists? + (string-append (getenv "HOME") "/" file)) + proc + #f))) + %files-configurations-alist) + (lambda (x y) + (equal? (procedure-name x) (procedure-name y)))))) + (map (lambda (proc) (proc)) configurations))) + +;; Based on `manifest->code' from (guix profiles) +;; MAYBE: Upstream it? +(define* (manifest->code manifest + #:key + (entry-package-version (const "")) + (home-environment? #f)) + "Return an sexp representing code to build an approximate version of +MANIFEST; the code is wrapped in a top-level 'begin' form. If +HOME-ENVIRONMENT? is #t, return an definition. +Call ENTRY-PACKAGE-VERSION to determine the version number to use in +the spec for a given entry; it can be set to 'manifest-entry-version' +for fully-specified version numbers, or to some other procedure to +disambiguate versions for packages for which several versions are +available." + (define (entry-transformations entry) + ;; Return the transformations that apply to ENTRY. + (assoc-ref (manifest-entry-properties entry) 'transformations)) + + (define transformation-procedures + ;; List of transformation options/procedure name pairs. + (let loop ((entries (manifest-entries manifest)) + (counter 1) + (result '())) + (match entries + (() result) + ((entry . tail) + (match (entry-transformations entry) + (#f + (loop tail counter result)) + (options + (if (assoc-ref result options) + (loop tail counter result) + (loop tail (+ 1 counter) + (alist-cons options + (string->symbol + (format #f "transform~a" counter)) + result))))))))) + + (define (qualified-name entry) + ;; Return the name of ENTRY possibly with "@" followed by a version. + (match (entry-package-version entry) + ("" (manifest-entry-name entry)) + (version (string-append (manifest-entry-name entry) + "@" version)))) + + (if (null? transformation-procedures) + (let ((specs (map (lambda (entry) + (match (manifest-entry-output entry) + ("out" (qualified-name entry)) + (output (string-append (qualified-name entry) + ":" output)))) + (manifest-entries manifest)))) + (if home-environment? + (let ((modules+configurations (modules+configurations))) + `(begin + (use-modules (gnu home) + (gnu packages) + ,@(map first modules+configurations)) + ,(home-environment-template + #:specs specs + #:services (map second modules+configurations)))) + `(begin + (use-modules (gnu packages)) + + (specifications->manifest + (list ,@specs))))) + (let* ((transform (lambda (options exp) + (if (not options) + exp + (let ((proc (assoc-ref transformation-procedures + options))) + `(,proc ,exp))))) + (packages (map (lambda (entry) + (define options + (entry-transformations entry)) + + (define name + (qualified-name entry)) + + (match (manifest-entry-output entry) + ("out" + (transform options + `(specification->package ,name))) + (output + `(list ,(transform + options + `(specification->package ,name)) + ,output)))) + (manifest-entries manifest))) + (transformations (map (match-lambda + ((options . name) + `(define ,name + (options->transformation ',options)))) + transformation-procedures))) + (if home-environment? + (let ((modules+configurations (modules+configurations))) + `(begin + (use-modules (guix transformations) + (gnu home) + (gnu packages) + ,@(map first modules+configurations)) + + ,@transformations + + ,(home-environment-template + #:packages packages + #:services (map second modules+configurations)))) + `(begin + (use-modules (guix transformations) + (gnu packages)) + + ,@transformations + + (packages->manifest + (list ,@packages))))))) + +(define* (home-environment-template #:key (packages #f) (specs #f) services) + "Return an S-exp containing a declaration +containing PACKAGES, or SPECS (package specifications), and SERVICES." + `(home-environment + (packages + ,@(if packages + `((list ,@packages)) + `((map specification->package + (list ,@specs))))) + (services (list ,@services)))) + +(define* (import-manifest + manifest + #:optional (port (current-output-port))) + "Write to PORT a corresponding to MANIFEST." + (define (version-spec entry) + (let ((name (manifest-entry-name entry))) + (match (map package-version (find-packages-by-name name)) + ((_) + ;; A single version of NAME is available, so do not specify the + ;; version number, even if the available version doesn't match ENTRY. + "") + (versions + ;; If ENTRY uses the latest version, don't specify any version. + ;; Otherwise return the shortest unique version prefix. Note that + ;; this is based on the currently available packages, which could + ;; differ from the packages available in the revision that was used + ;; to build MANIFEST. + (let ((current (manifest-entry-version entry))) + (if (every (cut version>? current <>) + (delete current versions)) + "" + (version-unique-prefix (manifest-entry-version entry) + versions))))))) + + (match (manifest->code manifest + #:entry-package-version version-spec + #:home-environment? #t) + (('begin exp ...) + (format port (G_ "\ +;; This \"home-environment\" file can be passed to 'guix home reconfigure' +;; to reproduce the content of your profile. This is \"symbolic\": it only +;; specifies package names. To reproduce the exact same profile, you also +;; need to capture the channels being used, as returned by \"guix describe\". +;; See the \"Replicating Guix\" section in the manual.\n")) + (for-each (lambda (exp) + (newline port) + (pretty-print exp port)) + exp))))