From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp0 ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms0.migadu.com with LMTPS id OOTHINUDKWEU1gAAgWs5BA (envelope-from ) for ; Fri, 27 Aug 2021 17:25:09 +0200 Received: from aspmx1.migadu.com ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp0 with LMTPS id 6BN5HNUDKWFcKAAA1q6Kng (envelope-from ) for ; Fri, 27 Aug 2021 15:25:09 +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 A6E83129B9 for ; Fri, 27 Aug 2021 17:25:08 +0200 (CEST) Received: from localhost ([::1]:54432 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1mJdj9-0001Wl-IL for larch@yhetil.org; Fri, 27 Aug 2021 11:25:07 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:59468) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mJdj4-0001WK-NQ for guix-patches@gnu.org; Fri, 27 Aug 2021 11:25:02 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:41205) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1mJdj4-0007V6-G0 for guix-patches@gnu.org; Fri, 27 Aug 2021 11:25:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1mJdj4-00015Z-AR for guix-patches@gnu.org; Fri, 27 Aug 2021 11:25: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: Fri, 27 Aug 2021 15:25:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 50208 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: Jelle Licht , 50208@debbugs.gnu.org Received: via spool by 50208-submit@debbugs.gnu.org id=B50208.16300778684141 (code B ref 50208); Fri, 27 Aug 2021 15:25:02 +0000 Received: (at 50208) by debbugs.gnu.org; 27 Aug 2021 15:24:28 +0000 Received: from localhost ([127.0.0.1]:52751 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mJdiV-00014i-H3 for submit@debbugs.gnu.org; Fri, 27 Aug 2021 11:24:28 -0400 Received: from mail-lj1-f176.google.com ([209.85.208.176]:46888) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mJdiS-00014U-N6 for 50208@debbugs.gnu.org; Fri, 27 Aug 2021 11:24:26 -0400 Received: by mail-lj1-f176.google.com with SMTP id w4so12010958ljh.13 for <50208@debbugs.gnu.org>; Fri, 27 Aug 2021 08:24:24 -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=C7tyVaGBYP8dy6P6vBi99zWmw5feQJIGSwTBlwTE7Gs=; b=wFGanPfDhc6CrW2E7TJApsuDBVuw3YMURCRzKyxjyr5ZbNKTouwVDYHqUjAQ6aHcwc 7VPGl2Jrwp5gsA5AGUtGMgH3MKFV0YF7yEywWyRYWkyBYx+c9QvDOeIeJcEMlJZAd8Wm WJMWdloNJUqp/O/6bZUSe++OqCmbkxkOOoiMr5T31/FIn5JbFf1Dbl4Phj05+myRrT9S gKNEdpPJRmDgv9Ifkh0m4S6K58CizAKuX1+/R0qxWc9MJtEsmxSKXTZbsWenBnHg6BRR nB7fQoY/CFjaGcYbwnosvzGwVF1OOi1Pd1aTKs6sHK2dWDXSGqtK0dD6sAua515RoUA4 yQrg== 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=C7tyVaGBYP8dy6P6vBi99zWmw5feQJIGSwTBlwTE7Gs=; b=HzAGJgCg+tdFhVJ4uCJMANLO8p/fEwjEk59LJEy/fJLJp22Up1uPBngEtnKZOq1+K0 uzVzh0DJNCVebdIt4GUJ2rCP3LLqoeUBZ1B+iaEj4YfteoRxGIwIItkm6wweWVxT+c7c kYWvrfbkSOXS5pCFhDSzaw7AXS9N9YSF6SuntCHcwF+JStTypLCBDhIDca5f9yxjay6Z nyJeE14I47/KYBDdJGrGoRCeqSGjWct9UnukXofRm0uwu+e5Af5g/GbcWWprUEIBQWrC bPLN+xwAwNNBY/Y4n2IvvtTuxBVhJlmue0p9oOm7zbru57rl0zwF492BrGWPFtfhueml EzZw== X-Gm-Message-State: AOAM530dNVxb9FLkt/1y6iNTl4iL5vNUtOVKPYYUyOKwm6ndFuaYfot7 fTMct1xioSodo4sPSLOmCLyx8g== X-Google-Smtp-Source: ABdhPJwV1z47HLTaCKrlOdyqm3lRBfA1tzsqSe1tzfpPoUtgaxY8cdTzYvohWtQTnAyRJRwZGQ4FVw== X-Received: by 2002:a2e:b4b9:: with SMTP id q25mr8031377ljm.180.1630077858295; Fri, 27 Aug 2021 08:24:18 -0700 (PDT) Received: from localhost (109-252-93-92.nat.spd-mgts.ru. [109.252.93.92]) by smtp.gmail.com with ESMTPSA id x33sm620097lfu.8.2021.08.27.08.24.16 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Fri, 27 Aug 2021 08:24:17 -0700 (PDT) From: Andrew Tropin In-Reply-To: <86zgt38dx3.fsf@fsfe.org> References: <87bl5kbsk8.fsf@trop.in> <86zgt38dx3.fsf@fsfe.org> Date: Fri, 27 Aug 2021 18:24:13 +0300 Message-ID: <877dg6di76.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=1630077909; 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=C7tyVaGBYP8dy6P6vBi99zWmw5feQJIGSwTBlwTE7Gs=; b=CG/QMf9sqgBEuvdBfZEnB80TkLGwJ/hQAOCCiAOwM0ot/u+OFHoAWYh5vOaMR7rYYzIUjx CwG/hi84jJFjJ+8qks08BxyToKLebRTwvI+xEdNSFHyak4PY6wNeoWX590cIQY0Lrn2F9z nlI+fbWzZeZj+eRvcazv0rksD6fl2azkIckFWO13VQBysn8PpbXledxY9yf2XmiyC/uiZF K5ImAs9GctER1HW4uTvQ55Yq4NS0YrOHxJd2wYSkOvtqqo0NfO6eB5Mr10kITpO9SGfb1E fntdSgMaUamn9jByLR1oaGBFHqDHFvjNVnWtyOOUcxHWq5+hQO9SEEF7TltyuQ== ARC-Seal: i=1; s=key1; d=yhetil.org; t=1630077909; a=rsa-sha256; cv=none; b=SJ9EZYhJrKoAAQrXthvVWT5VfwHsFp5hFhXazJCXoBIMKSB9+0zGGVl5KIqxUKhfR1uOAz 0yr0N3N2KZaxek5MrdY29KUxQPVUfzVyiMwSIzEdM/DFCHiIk8ORrBcf+end4QMz8nCsSx JU7MeW6sOjKEifZluZFU8vhGiXt29Ri8s4+tyugYwlPz3b+Byj810LbjLXPKaJ4C6DeMCF I8eIFRM430yAu7dTiy7vjkxefpDOk/1+FpIG4UxYaZgp320mwm9ujI6KGEoJvknu0Fi0ir jLi6xY84UV9KwAR7bB2ViETlR5bl7hXEJnmB1P/IK6HxQbWnJl7Tw+HEfOcpjw== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("headers rsa verify failed") header.d=trop-in.20150623.gappssmtp.com header.s=20150623 header.b=wFGanPfD; 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.53 Authentication-Results: aspmx1.migadu.com; dkim=fail ("headers rsa verify failed") header.d=trop-in.20150623.gappssmtp.com header.s=20150623 header.b=wFGanPfD; 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: A6E83129B9 X-Spam-Score: -3.53 X-Migadu-Scanner: scn0.migadu.com X-TUID: nTAnak3kOqza --==-=-= Content-Type: multipart/mixed; boundary="=-=-=" --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable On 2021-08-27 10:55, Jelle Licht wrote: > Hey Andrew, > > some nits, as requested! > > Andrew Tropin writes: > >> --- >> 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 atte= ntion, >> because it's most unpure part of the Guix Home and operates on user's fi= les. >> >> 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/s= ymlink-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 =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 (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 > > s/backups/backs up > >> +;;; created by user, removes symlinks and directories created by > missing the/a >> +;;; previous generation, and creates new directories and symlinks to >> +;;; configs according to content of files/ directory of current home > > I don't really get the last part of this sentence. > Slightly rewrote it, hope now it's easier to understand: ;;; symlink-manager cares about configuration files: it backs up files ;;; created by user, removes symlinks and directories created by a ;;; previous generation, and creates new directories and symlinks to ;;; configuration files according to the content of files/ directory ;;; (created by home-files-service) of the current home environment ;;; generation. > >> +;;; 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)) > The formatting seems off. In addition, I notice there are tab characters > in the patch for some reason, you should be able to have emacs Do The > Right Thing if you hack within a Guix git checkout. Already fixed. > >> + (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 PREORDERIN= G. >> + >> +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." > s/folders/(sub-)directories Done. >> + (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")) > > This is a path to a transient location for the new home environment, > correct? Yup. >=20 > tmp-path, to me at least, evokes a place where temporary files are > stored, contrasted to a temporary home for important files. > Removed tmp suffix. > >> + >> + (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"))) > > A couple of the previous lambdas could have been `define'd (as a nested > define) instead of put in this binding form. > Yes, but some of them are closures and have to be in the let or deeper in the tree, so I decided to put them all in the let. > >> + >> + (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")) > > I think a let-binding for (get-target-path path) would work well here. > >> + (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. > > `by user' does not add anything; Referring to modified is slightly > confusing, as I can change the symlink to point to a different file in > the store and it will happily be deleted at this point in time. > > what about: > DO NOT remote the file if it is no longer a symblink to the store. It > will be backed up later during the create-symlinks phase. > Sounds good, picked this one. > >> + (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 > creates,removes. >> +target is occupied by a file created by user, back it up."))) > What is target? Why should I care as a user of this service :)? > Perhaps rather than describing how the service does what it does, somethi= ng in > the spirit of; > > If an existing file would be overwritten by a symlink, back up > the exiting file first. Updated. > >> --=20 >> 2.33.0 > > A nitpick I'm much less certain about is your use of display (and > format) without using the G_ macro; Perhaps you can try to reach out to > the folks who are most involved with the translation effort to see if > there is something that needs to be addressed now, of whether that can > still easily happen at a later point? > Yep, it's very likely that there is a better mechanism for providing output than display function, but I think it can be easily updated later. >=20 > Thanks again for working on this! - Jelle Cleaned up and updated the script. --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: inline; filename=v2-0001-home-services-Add-symlink-manager.patch Content-Transfer-Encoding: quoted-printable From=202a755c1061098e73975dfd539eb25cb3fff98533 Mon Sep 17 00:00:00 2001 From: Andrew Tropin Date: Thu, 26 Aug 2021 09:39:38 +0300 Subject: [PATCH v2] home-services: Add symlink-manager. * gnu/home-services/symlink-manager.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add home-services/symlink-manager.scm. =2D-- gnu/home-services/symlink-manager.scm | 247 ++++++++++++++++++++++++++ gnu/local.mk | 1 + 2 files 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/syml= ink-manager.scm new file mode 100644 index 0000000000..dc409d2ae2 =2D-- /dev/null +++ b/gnu/home-services/symlink-manager.scm @@ -0,0 +1,247 @@ +;;; 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 (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 backs up files +;;; created by user, removes symlinks and directories created by a +;;; previous generation, and creates new directories and symlinks to +;;; configuration files according to the content of files/ directory +;;; (created by home-files-service) of the current home environment +;;; generation. +;;; +;;; 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 PREORD= ERING. + +if PREORDERING is @code{#t} resulting list will contain directories +before files located in those directories, otherwise directory 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* ((config-home (or (getenv "XDG_CONFIG_HOME") + (string-append (getenv "HOME") "/.config= "))) + + (he-path (string-append (getenv "HOME") "/.guix-home")) + (new-he-path (string-append he-path ".new")) + (new-home (getenv "GUIX_NEW_HOME")) + (old-home (getenv "GUIX_OLD_HOME")) + + (new-files-path (string-append new-home "/files")) + ;; Trailing dot is required, because files itself is symlink= and + ;; to make file-system-tree works it should be a directory. + (new-files-dir-path (string-append new-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? old-home) + ((simplify-file-tree "") + (file-system-tree + (string-append old-home "/files/."))) + #f)) + (new-tree ((simplify-file-tree "") + (file-system-tree new-files-dir-path))) + + (get-source-path + (lambda (path) + (readlink (string-append new-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)... do= ne\n" + (get-target-path path)))) + + (('file . path) + (when (file-exists? (get-target-path path)) + ;; DO NOT remove the file if it is no longer + ;; a symlink to the store, 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-pat= h path)) + (delete-file (get-target-path path)) + (display " done\n")) + (format + #t + "Skipping ~a (not a symlink to store)... don= e\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" back= up-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 pat= h)) + (symlink (get-source-path path) (get-target-path pa= th)) + (display " done\n"))) + to-create))))) + + (when old-tree + (cleanup-symlinks)) + + (create-symlinks) + + (symlink new-home new-he-path) + (rename-file new-he-path he-path) + + (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 creates symlinks to configuration files and directories +on every activation. If an existing file would be overwritten by a +symlink, backs up that file first."))) diff --git a/gnu/local.mk b/gnu/local.mk index bd3aed77e8..91c3b0da3d 100644 =2D-- a/gnu/local.mk +++ b/gnu/local.mk @@ -73,6 +73,7 @@ GNU_SYSTEM_MODULES =3D \ %D%/bootloader/depthcharge.scm \ %D%/ci.scm \ %D%/home-services.scm \ + %D%/home-services/symlink-manager.scm \ %D%/image.scm \ %D%/packages.scm \ %D%/packages/abduco.scm \ =2D-=20 2.33.0 --=-=-=-- --==-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQIzBAEBCgAdFiEEKEGaxlA4dEDH6S/6IgjSCVjB3rAFAmEpA50ACgkQIgjSCVjB 3rBg0Q//aVX25FamMjeS5tdarecXbavq973ZQA4rsZF7I1LuXfcCWbvGlxWIk641 9SPcMCkU0zG9h4nzrW5xlCrcC2NqCZHM2iGY5wbrc5ExHMZXbiq4VCC7S3/KsrMV NHbHgHMD/dczdiUr5AtCVoQYWFpPm3xHl4yKcIYaUZBYyiEizce2+/JII7u8pEXo oQnCdI4B36rwjz/Yky973oDG0UnBush4Cua7fu6SfrutrPkHb292uPoczS0pIuo2 K29UPqFqDrhBZ+J+P4IerL4wC1nfCwMNjD23Y8UxwRiXsda/2wTHiaMAR9mYImMm FRbfMWMi4Ar+goZpRaTdLaHjYN606p5w/j7bzN1uWBH0N3keLbtbNk6C+mWfd/Wi HfBsQhbPH1hcf9BXxXumoO2JAs+jXt2+Rsp2bFbMhKDWnTG1Wc1bMfaqTL4Z74xV kW6+dpJEWR12gOwmUSTAlM/Now1nNmDbU/KL1mDwjnnM9DuZVDmNdKfkvQX16CBp ThSGmOPp3jjUvIfgkgMC5wMbyQ6HiwDrYSYQdCq/l1QC7a2l31NDk2a6QKEdlTs/ LOoDpXgfRNbBc4Kq6wi3+WnFForEYw6NnOZn5YmfAny5Lg6/rtCULswIsPoMcp1U 5Gab/aZGNoghHn8SXGtcNc9ApvGPl1I7dJq5XrguMZ3x7VVKc8Y= =Y18q -----END PGP SIGNATURE----- --==-=-=--