From patchwork Thu Aug 26 06:39:38 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Andrew Tropin X-Patchwork-Id: 32301 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 E6B8927BBE5; Thu, 26 Aug 2021 08:00:16 +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=ham 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 8C5E627BBE4 for ; Thu, 26 Aug 2021 08:00:14 +0100 (BST) Received: from localhost ([::1]:57110 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1mJ9Mz-0003h6-Ia for patchwork@mira.cbaines.net; Thu, 26 Aug 2021 03:00:13 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:53810) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mJ9Mo-0003gv-Ln for guix-patches@gnu.org; Thu, 26 Aug 2021 03:00:02 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:36712) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1mJ9Mo-0005A1-DS for guix-patches@gnu.org; Thu, 26 Aug 2021 03:00:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1mJ9Mo-0000vG-8l for guix-patches@gnu.org; Thu, 26 Aug 2021 03:00:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#50208] [PATCH] home-services: Add symlink-manager Resent-From: Andrew Tropin Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 26 Aug 2021 07:00:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 50208 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 50208@debbugs.gnu.org X-Debbugs-Original-To: guix-patches@gnu.org Received: via spool by submit@debbugs.gnu.org id=B.16299611513458 (code B ref -1); Thu, 26 Aug 2021 07:00:02 +0000 Received: (at submit) by debbugs.gnu.org; 26 Aug 2021 06:59:11 +0000 Received: from localhost ([127.0.0.1]:48258 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mJ9Ly-0000th-Se for submit@debbugs.gnu.org; Thu, 26 Aug 2021 02:59:11 -0400 Received: from lists.gnu.org ([209.51.188.17]:60222) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mJ9Lv-0000tX-MV for submit@debbugs.gnu.org; Thu, 26 Aug 2021 02:59:09 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:53678) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mJ9Lv-0003Re-5Q for guix-patches@gnu.org; Thu, 26 Aug 2021 02:59:07 -0400 Received: from mail-lj1-x22b.google.com ([2a00:1450:4864:20::22b]:42912) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1mJ9Ls-0004LB-Vr for guix-patches@gnu.org; Thu, 26 Aug 2021 02:59:06 -0400 Received: by mail-lj1-x22b.google.com with SMTP id h1so3233160ljl.9 for ; Wed, 25 Aug 2021 23:59:04 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=trop-in.20150623.gappssmtp.com; s=20150623; h=from:to:subject:date:message-id:mime-version; bh=lpore3BqW/kYSGHygM+p5rde5zecCbH4eBzFAyONhgg=; b=MtBAz++oKtHZPsT+CkgMiDHB9vJMEmc89Xks4msQDkA8R6K0p6qhPhF3nDNCqHZRhX DF6TJRS+IWV62nBBc3hLVB7lZ4tGN1jVgt/zz0fxsU1XYtCiwyJRrsZwQy1R0bhaOncH Qe/+JN8EfBkLEPoFRzWbh4BUq5vgixxvp2HIOp91+Djmnif0e4N9NAlOIzYfhARIsCk8 h8RSB14PlyB1O4QeSC+R02ivCm5r1HHd1qoxSQ7xOqxTF1kQtDYUaHVDNbw2rdxRSi+Q +/pV8FkzY6Hg+yaGf6dXcx9sf7zIUX93ybPwFK7z0wjo48K3YRJcwhLLdWFZgJFcakt9 lteg== 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:date:message-id:mime-version; bh=lpore3BqW/kYSGHygM+p5rde5zecCbH4eBzFAyONhgg=; b=iUP7mS8ckgAlomHzEOCP/hxGH3elSTgTOI8Oy3aGZHfbQVvOwjbyqTDyEve9IiS/CK ced7y4z9/6RM6iOLri78bax5ViVSamR354djjZeRCtNAyJ8AbkkQjJ498WCLWORSkMJl gX9gFnK/NEoTAZ69Shnibu+TO85Fz0YTnlsKF3nr0Xkr6jR8Dw/WDcNh8dpbL3K3vov+ 1pfmns/cMJvY2YVtbJBXrfo+LScTjDmfbK90ZWj6UNdALVSmzXsVekQC8M8a4w7axsdU I7H7s7TsqEGo1vDUlUM4NJYOrSvdHj+AL8OzmDBuSCFRukruwhOkXuseT/AI4X09yAck fJiw== X-Gm-Message-State: AOAM532mxWJYQ4UTYaDbdAbKop0H0qNNI4tYwamvM0My3ncK9e43fbtT aPMU1JZAAVDrjvjsdAsWE35hK59sSDvIhw== X-Google-Smtp-Source: ABdhPJwj6ZJ/k4UT1qKrLaiWzg6yGRJHSd+8nj1soB8Ki1ttIaNO4gXrAgSoIjZ+C9yH2gv5i8D/bQ== X-Received: by 2002:a2e:9e05:: with SMTP id e5mr1777206ljk.166.1629961142044; Wed, 25 Aug 2021 23:59:02 -0700 (PDT) Received: from localhost ([109.252.93.92]) by smtp.gmail.com with ESMTPSA id r193sm226247lff.187.2021.08.25.23.59.00 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 25 Aug 2021 23:59:01 -0700 (PDT) From: Andrew Tropin Date: Thu, 26 Aug 2021 09:39:38 +0300 Message-ID: <87bl5kbsk8.fsf@trop.in> MIME-Version: 1.0 Received-SPF: none client-ip=2a00:1450:4864:20::22b; envelope-from=andrew@trop.in; helo=mail-lj1-x22b.google.com X-Spam_score_int: -18 X-Spam_score: -1.9 X-Spam_bar: - X-Spam_report: (-1.9 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_NONE=0.001 autolearn=ham autolearn_force=no X-Spam_action: no action 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 --- This patch is targeted against wip-guix-home branch. It's not a part of any patch series to make sure it will get enough attention, because it's most unpure part of the Guix Home and operates on user's files. gnu/home-services/symlink-manager.scm | 248 ++++++++++++++++++++++++++ 1 file changed, 248 insertions(+) create mode 100644 gnu/home-services/symlink-manager.scm diff --git a/gnu/home-services/symlink-manager.scm b/gnu/home-services/symlink-manager.scm new file mode 100644 index 0000000000..f13c9f4dbe --- /dev/null +++ b/gnu/home-services/symlink-manager.scm @@ -0,0 +1,248 @@ +;;; 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 (gnu home-services symlink-manager) + #:use-module (gnu home-services) + #:use-module (guix gexp) + + #:export (home-symlink-manager-service-type)) + +;;; Comment: +;;; +;;; symlink-manager cares about configuration files: it backups files +;;; created by user, removes symlinks and directories created by +;;; previous generation, and creates new directories and symlinks to +;;; configs according to content of files/ directory of current home +;;; environment generation (created by home-files-service). +;;; +;;; Code: + +(define (update-symlinks-script) + (program-file + "update-symlinks" + #~(begin + (use-modules (ice-9 ftw) + (ice-9 curried-definitions) + (ice-9 match) + (srfi srfi-1)) + (define ((simplify-file-tree parent) file) + "Convert the result produced by `file-system-tree' to less +verbose and more suitable for further processing format. + +Extract dir/file info from stat and compose a relative path to the +root of the file tree. + +Sample output: + +((dir . \".\") + ((dir . \"config\") + ((dir . \"config/fontconfig\") + (file . \"config/fontconfig/fonts.conf\")) + ((dir . \"config/isync\") + (file . \"config/isync/mbsyncrc\")))) +" + (match file + ((name stat) `(file . ,(string-append parent name))) + ((name stat children ...) + (cons `(dir . ,(string-append parent name)) + (map (simplify-file-tree + (if (equal? name ".") + "" + (string-append parent name "/"))) + children))))) + + (define ((file-tree-traverse preordering) node) + "Traverses the file tree in different orders, depending on PREORDERING. + +if PREORDERING is @code{#t} resulting list will contain folders before +files located in those folders, otherwise folders will appear only +after all nested items already listed." + (let ((prepend (lambda (a b) (append b a)))) + (match node + (('file . path) (list node)) + ((('dir . path) . rest) + ((if preordering append prepend) + (list (cons 'dir path)) + (append-map (file-tree-traverse preordering) rest)))))) + + (use-modules (guix build utils)) + + (let* ((he-path (string-append (getenv "HOME") "/.guix-home")) + (new-he-tmp-path (string-append he-path ".new")) + (new-home (getenv "GUIX_NEW_HOME"))) + (symlink new-home new-he-tmp-path) + (rename-file new-he-tmp-path he-path)) + + (let* ((config-home (or (getenv "XDG_CONFIG_HOME") + (string-append (getenv "HOME") "/.config"))) + + (he-path (string-append (getenv "HOME") "/.guix-home")) + (new-he-tmp-path (string-append he-path ".new")) + + (files-path (string-append he-path "/files")) + ;; Leading dot is required, because files itself is symlink and + ;; to make file-system-tree works it should be a directory. + (files-dir-path (string-append files-path "/.")) + (new-files-path (string-append new-he-tmp-path "/files")) + (new-files-dir-path (string-append files-path "/.")) + + (home-path (getenv "HOME")) + (backup-dir (string-append home-path "/" + (number->string (current-time)) + "-guix-home-legacy-configs-backup")) + + (old-tree (if (file-exists? files-dir-path) + ((simplify-file-tree "") + (file-system-tree files-dir-path)) + #f)) + (new-tree ((simplify-file-tree "") + (file-system-tree new-files-dir-path))) + + (get-source-path + (lambda (path) + (readlink (string-append files-path "/" path)))) + + (get-target-path + (lambda (path) + (string-append home-path "/." path))) + + (get-backup-path + (lambda (path) + (string-append backup-dir "/." path))) + + (directory? + (lambda (path) + (equal? (stat:type (stat path)) 'directory))) + + (empty-directory? + (lambda (dir) + (equal? (scandir dir) '("." "..")))) + + (symlink-to-store? + (lambda (path) + (and + (equal? (stat:type (lstat path)) 'symlink) + (store-file-name? (readlink path))))) + + (backup-file + (lambda (path) + (mkdir-p backup-dir) + (format #t "Backing up ~a..." (get-target-path path)) + (mkdir-p (dirname (get-backup-path path))) + (rename-file (get-target-path path) (get-backup-path path)) + (display " done\n"))) + + (cleanup-symlinks + (lambda () + (let ((to-delete ((file-tree-traverse #f) old-tree))) + (display + "Cleaning up symlinks from previous home-environment.\n\n") + (map + (match-lambda + (('dir . ".") + (display "Cleanup finished.\n\n")) + + (('dir . path) + (if (and + (file-exists? (get-target-path path)) + (directory? (get-target-path path)) + (empty-directory? (get-target-path path))) + (begin + (format #t "Removing ~a..." + (get-target-path path)) + (rmdir (get-target-path path)) + (display " done\n")) + (format + #t "Skipping ~a (not an empty directory)... done\n" + (get-target-path path)))) + + (('file . path) + (when (file-exists? (get-target-path path)) + ;; DO NOT remove the file if it was modified + ;; by user (not a symlink to the /gnu/store + ;; anymore) it will be backed up later during + ;; create-symlinks phase. + (if (symlink-to-store? (get-target-path path)) + (begin + (format #t "Removing ~a..." (get-target-path path)) + (delete-file (get-target-path path)) + (display " done\n")) + (format + #t + "Skipping ~a (not a symlink to store)... done\n" + (get-target-path path)))))) + to-delete)))) + + (create-symlinks + (lambda () + (let ((to-create ((file-tree-traverse #t) new-tree))) + (map + (match-lambda + (('dir . ".") + (display + "New symlinks to home-environment will be created soon.\n") + (format + #t "All conflicting files will go to ~a.\n\n" backup-dir)) + + (('dir . path) + (let ((target-path (get-target-path path))) + (when (and (file-exists? target-path) + (not (directory? target-path))) + (backup-file path)) + + (if (file-exists? target-path) + (format + #t "Skipping ~a (directory already exists)... done\n" + target-path) + (begin + (format #t "Creating ~a..." target-path) + (mkdir target-path) + (display " done\n"))))) + + (('file . path) + (when (file-exists? (get-target-path path)) + (backup-file path)) + (format #t "Symlinking ~a -> ~a..." + (get-target-path path) (get-source-path path)) + (symlink (get-source-path path) (get-target-path path)) + (display " done\n"))) + to-create))))) + + (when old-tree + (cleanup-symlinks)) + + (create-symlinks) + + (display " done\nFinished updating symlinks.\n\n"))))) + + +(define (update-symlinks-gexp _) + #~(primitive-load #$(update-symlinks-script))) + +(define home-symlink-manager-service-type + (service-type (name 'home-symlink-manager) + (extensions + (list + (service-extension + home-activation-service-type + update-symlinks-gexp))) + (default-value #f) + (description "Provide an @code{update-symlinks} +script, which create and remove symlinks on every activation. If the +target is occupied by a file created by user, back it up.")))