Subject: [bug#50208] [PATCH] home-services: Add symlink-manager

From: Andrew Tropin <[email-masked]>
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 <[email-masked]> 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 <[email-masked]>
>> +;;; Copyright © 2021 Xinglu Chen <[email-masked]>
>> +;;;
>> +;;; 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 <[email-masked]>
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 <[email-masked]>
+;;; Copyright © 2021 Xinglu Chen <[email-masked]>
+;;;
+;;; 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