[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#50208] [PATCH] home-services: Add symlink-manager
|
From: |
Andrew Tropin |
|
Subject: |
[bug#50208] [PATCH] home-services: Add symlink-manager |
|
Date: |
Fri, 27 Aug 2021 18:24:13 +0300 |
On 2021-08-27 10:55, Jelle Licht wrote:
> Hey Andrew,
>
> some nits, as requested!
>
> Andrew Tropin <andrew@trop.in> 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
>> 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 <andrew@trop.in>
>> +;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
>> +;;;
>> +;;; 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 <http://www.gnu.org/licenses/>.
>> +
>> +(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 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."
> 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.
>
> 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, something in
> the spirit of;
>
> If an existing file would be overwritten by a symlink, back up
> the exiting file first.
Updated.
>
>> --
>> 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.
>
> Thanks again for working on this! - Jelle
Cleaned up and updated the script.
From 2a755c1061098e73975dfd539eb25cb3fff98533 Mon Sep 17 00:00:00 2001
From: Andrew Tropin <andrew@trop.in>
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.
---
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/symlink-manager.scm
new file mode 100644
index 0000000000..dc409d2ae2
--- /dev/null
+++ b/gnu/home-services/symlink-manager.scm
@@ -0,0 +1,247 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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
PREORDERING.
+
+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)... done\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-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)
+
+ (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
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -73,6 +73,7 @@ GNU_SYSTEM_MODULES = \
%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 \
--
2.33.0
signature.asc
Description: PGP signature
- [bug#50208] [PATCH 1/5] home-services: Add fontutils., (continued)
- [bug#50208] [PATCH 4/5] home-services: Add xdg., Andrew Tropin, 2021/08/27
- [bug#50208] [PATCH 5/5] home: Add home-environment., Andrew Tropin, 2021/08/27
- [bug#50208] [PATCH 5/5] home: Add home-environment., Xinglu Chen, 2021/08/28
- [bug#50208] [PATCH 0/5] Add home-environment and related services, Andrew Tropin, 2021/08/27
- bug#50208: [PATCH 0/5] Add home-environment and related services, Oleg Pykhalov, 2021/08/27
[bug#50208] [PATCH] home-services: Add symlink-manager, Jelle Licht, 2021/08/27
- [bug#50208] [PATCH] home-services: Add symlink-manager,
Andrew Tropin <=