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

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

[Andrew Tropin]

[-- Attachment #1: Type: text/plain, Size: 9310 bytes --]


---
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
+;;; 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.")))
-- 
2.33.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 853 bytes --]

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

[Oleg Pykhalov]

[-- Attachment #1.1: Type: text/plain, Size: 933 bytes --]

Hi Andrew,

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
>

[…]

I applied your patch, replaces tabs with spaces, modified commit message
according to GNU standards, added the file to gnu/local.mk for
compilation (I forgot to do it for previous patch series, apologies).


I would like to squash the patch for home-services.scm with a previous
series (hope force push will work), but I should ask you could I do it?
Otherwise I could just push two patches to wip-guix-home.

Updated patches are attached below.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.2: 0001-gnu-Compile-home-services.patch --]
[-- Type: text/x-patch, Size: 799 bytes --]

From 99f1b412fd76d9813dccc96cf30a943375d0d5a8 Mon Sep 17 00:00:00 2001
From: Oleg Pykhalov <go.wigust@gmail.com>
Date: Thu, 26 Aug 2021 13:18:54 +0300
Subject: [PATCH 1/2] gnu: Compile home-services.

This commit follows b784de19.

* gnu/local.mk (GNU_SYSTEM_MODULES): Add home-services.scm.
---
 gnu/local.mk | 1 +
 1 file changed, 1 insertion(+)

diff --git a/gnu/local.mk b/gnu/local.mk
index 14cd1cc6ad..bd3aed77e8 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -72,6 +72,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/bootloader/u-boot.scm                     \
   %D%/bootloader/depthcharge.scm                \
   %D%/ci.scm					\
+  %D%/home-services.scm                         \
   %D%/image.scm					\
   %D%/packages.scm				\
   %D%/packages/abduco.scm			\
-- 
2.32.0


[-- Attachment #1.3: 0002-home-services-Add-symlink-manager.patch --]
[-- Type: text/x-patch, Size: 11933 bytes --]

From 8938342edec4dda6ff2b7b5d47f63809bb309084 Mon Sep 17 00:00:00 2001
From: Andrew Tropin <andrew@trop.in>
Date: Thu, 26 Aug 2021 09:39:38 +0300
Subject: [PATCH 2/2] home-services: Add symlink-manager.

* gnu/home-services/symlink-manager.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add this.

Signed-off-by: Oleg Pykhalov <go.wigust@gmail.com>
---
 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..47fee8db3b
--- /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 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.")))
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.32.0


[-- Attachment #1.4: Type: text/plain, Size: 7 bytes --]


Oleg.

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 861 bytes --]

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

[Andrew Tropin]

[-- Attachment #1: Type: text/plain, Size: 14394 bytes --]

On 2021-08-26 13:58, Oleg Pykhalov wrote:

> Hi Andrew,
>
> 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
>>
>
> […]
>
> I applied your patch, replaces tabs with spaces, modified commit message
> according to GNU standards, added the file to gnu/local.mk for
> compilation (I forgot to do it for previous patch series, apologies).
>

Thank you!

>
>
> I would like to squash the patch for home-services.scm with a previous
> series (hope force push will work), but I should ask you could I do it?
> Otherwise I could just push two patches to wip-guix-home.
>

Yes, squash works for me.

> 
> Updated patches are attached below.
>
> From 99f1b412fd76d9813dccc96cf30a943375d0d5a8 Mon Sep 17 00:00:00 2001
> From: Oleg Pykhalov <go.wigust@gmail.com>
> Date: Thu, 26 Aug 2021 13:18:54 +0300
> Subject: [PATCH 1/2] gnu: Compile home-services.
>
> This commit follows b784de19.
>
> * gnu/local.mk (GNU_SYSTEM_MODULES): Add home-services.scm.
> ---
>  gnu/local.mk | 1 +
>  1 file changed, 1 insertion(+)
>
> diff --git a/gnu/local.mk b/gnu/local.mk
> index 14cd1cc6ad..bd3aed77e8 100644
> --- a/gnu/local.mk
> +++ b/gnu/local.mk
> @@ -72,6 +72,7 @@ GNU_SYSTEM_MODULES =				\
>    %D%/bootloader/u-boot.scm                     \
>    %D%/bootloader/depthcharge.scm                \
>    %D%/ci.scm					\
> +  %D%/home-services.scm                         \
>    %D%/image.scm					\
>    %D%/packages.scm				\
>    %D%/packages/abduco.scm			\
> -- 
> 2.32.0
>
> From 8938342edec4dda6ff2b7b5d47f63809bb309084 Mon Sep 17 00:00:00 2001
> From: Andrew Tropin <andrew@trop.in>
> Date: Thu, 26 Aug 2021 09:39:38 +0300
> Subject: [PATCH 2/2] home-services: Add symlink-manager.
>
> * gnu/home-services/symlink-manager.scm: New file.
> * gnu/local.mk (GNU_SYSTEM_MODULES): Add this.
>
> Signed-off-by: Oleg Pykhalov <go.wigust@gmail.com>
> ---
>  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..47fee8db3b
> --- /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 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.")))
> 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			\

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 853 bytes --]

[bug#50208] [PATCH 0/5] Add home-environment and related services

[Andrew Tropin]

[-- Attachment #1: Type: text/plain, Size: 1547 bytes --]

On 2021-08-26 13:58, Oleg Pykhalov wrote:

> I applied your patch, replaces tabs with spaces, modified commit message
> according to GNU standards, added the file to gnu/local.mk for
> compilation (I forgot to do it for previous patch series, apologies).
>
>
> I would like to squash the patch for home-services.scm with a previous
> series (hope force push will work), but I should ask you could I do it?
> Otherwise I could just push two patches to wip-guix-home.
>
> Updated patches are attached below.

On top of the patches above I made a new patch series, which introduces
home-environment and a set of default services, which are expected to be
present in most Guix Home configurations.

Andrew Tropin (5):
  home-services: Add fontutils.
  home-services: Add helper functions for service configurations.
  home-services: Add shells.
  home-services: Add xdg.
  home: Add home-environment.

 gnu/home-services/configuration.scm |  63 +++
 gnu/home-services/fontutils.scm     |  65 +++
 gnu/home-services/shells.scm        | 637 ++++++++++++++++++++++++++++
 gnu/home-services/xdg.scm           | 475 +++++++++++++++++++++
 gnu/home.scm                        |  97 +++++
 gnu/local.mk                        |   5 +
 6 files changed, 1342 insertions(+)
 create mode 100644 gnu/home-services/configuration.scm
 create mode 100644 gnu/home-services/fontutils.scm
 create mode 100644 gnu/home-services/shells.scm
 create mode 100644 gnu/home-services/xdg.scm
 create mode 100644 gnu/home.scm

-- 
2.33.0

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 853 bytes --]

[bug#50208] [PATCH 1/5] home-services: Add fontutils.

[Andrew Tropin]

[-- Attachment #1: Type: text/plain, Size: 3600 bytes --]


* gnu/home-services/fontutils.scm (home-fontconfig-service-type): New
variable.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add home-services/fontutils.scm.
---
 gnu/home-services/fontutils.scm | 65 +++++++++++++++++++++++++++++++++
 gnu/local.mk                    |  1 +
 2 files changed, 66 insertions(+)
 create mode 100644 gnu/home-services/fontutils.scm

diff --git a/gnu/home-services/fontutils.scm b/gnu/home-services/fontutils.scm
new file mode 100644
index 0000000000..28bfc3d3f7
--- /dev/null
+++ b/gnu/home-services/fontutils.scm
@@ -0,0 +1,65 @@
+;;; 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 fontutils)
+  #:use-module (gnu home-services)
+  #:use-module (gnu packages fontutils)
+  #:use-module (guix gexp)
+
+  #:export (home-fontconfig-service-type))
+
+;;; Commentary:
+;;;
+;;; Services related to fonts.  home-fontconfig service provides
+;;; fontconfig configuration, which allows fc-* utilities to find
+;;; fonts in Guix Home's profile and regenerates font cache on
+;;; activation.
+;;;
+;;; Code:
+
+(define (add-fontconfig-config-file he-symlink-path)
+  `(("config/fontconfig/fonts.conf"
+     ,(mixed-text-file
+       "fonts.conf"
+       "<?xml version='1.0'?>
+<!DOCTYPE fontconfig SYSTEM 'fonts.dtd'>
+<fontconfig>
+  <dir>~/.guix-home/profile/share/fonts</dir>
+</fontconfig>"))))
+
+(define (regenerate-font-cache-gexp _)
+  `(("profile/share/fonts"
+     ,#~(system* #$(file-append fontconfig "/bin/fc-cache") "-fv"))))
+
+(define home-fontconfig-service-type
+  (service-type (name 'home-fontconfig)
+                (extensions
+                 (list (service-extension
+                        home-files-service-type
+                        add-fontconfig-config-file)
+                       (service-extension
+                        home-run-on-change-service-type
+                        regenerate-font-cache-gexp)
+                       (service-extension
+                        home-profile-service-type
+                        (const (list fontconfig)))))
+                (default-value #f)
+                (description
+                 "Provides configuration file for fontconfig and make
+fc-* utilities aware of font packages installed in Guix Home's profile.")))
diff --git a/gnu/local.mk b/gnu/local.mk
index 91c3b0da3d..e25ff3db53 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -74,6 +74,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/ci.scm					\
   %D%/home-services.scm                         \
   %D%/home-services/symlink-manager.scm         \
+  %D%/home-services/fontutils.scm               \
   %D%/image.scm					\
   %D%/packages.scm				\
   %D%/packages/abduco.scm			\
-- 
2.33.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 853 bytes --]

[bug#50208] [PATCH 2/5] home-services: Add helper functions for service configurations.

[Andrew Tropin]

[-- Attachment #1: Type: text/plain, Size: 3129 bytes --]

* gnu/home-services/configuration.scm (helper functions): New variables.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add home-services/configuration.scm.
---
 gnu/home-services/configuration.scm | 63 +++++++++++++++++++++++++++++
 gnu/local.mk                        |  1 +
 2 files changed, 64 insertions(+)
 create mode 100644 gnu/home-services/configuration.scm

diff --git a/gnu/home-services/configuration.scm b/gnu/home-services/configuration.scm
new file mode 100644
index 0000000000..b7487fc49f
--- /dev/null
+++ b/gnu/home-services/configuration.scm
@@ -0,0 +1,63 @@
+(define-module (gnu home-services configuration)
+  #:use-module (gnu services configuration)
+  #:use-module (guix gexp)
+  #:use-module (srfi srfi-1)
+
+  #:export (filter-configuration-fields
+
+            interpose
+            list-of
+
+            list-of-strings?
+            alist?
+            string-or-gexp?
+	    serialize-string-or-gexp
+	    text-config?
+            serialize-text-config))
+
+(define* (filter-configuration-fields configuration-fields fields
+				      #:optional negate?)
+  "Retrieve the fields listed in FIELDS from CONFIGURATION-FIELDS.
+If NEGATE? is @code{#t}, retrieve all fields except FIELDS."
+  (filter (lambda (field)
+            (let ((member? (member (configuration-field-name field) fields)))
+              (if (not negate?) member? (not member?))))
+          configuration-fields))
+
+
+(define* (interpose ls  #:optional (delimiter "\n") (grammar 'infix))
+  "Same as @code{string-join}, but without join and string, returns an
+DELIMITER interposed LS.  Support 'infix and 'suffix GRAMMAR values."
+  (when (not (member grammar '(infix suffix)))
+    (raise
+     (formatted-message
+      (G_ "The GRAMMAR value must be 'infix or 'suffix, but ~a provided.")
+      grammar)))
+  (fold-right (lambda (e acc)
+		(cons e
+		      (if (and (null? acc) (eq? grammar 'infix))
+			  acc
+			  (cons delimiter acc))))
+	      '() ls))
+
+(define (list-of pred?)
+  "Return a procedure that takes a list and check if all the elements of
+the list result in @code{#t} when applying PRED? on them."
+    (lambda (x)
+      (if (list? x)
+          (every pred? x)
+          #f)))
+
+
+(define list-of-strings?
+  (list-of string?))
+
+(define alist? list?)
+
+(define (string-or-gexp? sg) (or (string? sg) (gexp? sg)))
+(define (serialize-string-or-gexp field-name val) "")
+
+(define (text-config? config)
+  (and (list? config) (every string-or-gexp? config)))
+(define (serialize-text-config field-name val)
+  #~(string-append #$@(interpose val "\n" 'suffix)))
diff --git a/gnu/local.mk b/gnu/local.mk
index e25ff3db53..e24da4716f 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -75,6 +75,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/home-services.scm                         \
   %D%/home-services/symlink-manager.scm         \
   %D%/home-services/fontutils.scm               \
+  %D%/home-services/configuration.scm           \
   %D%/image.scm					\
   %D%/packages.scm				\
   %D%/packages/abduco.scm			\
-- 
2.33.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 853 bytes --]

[bug#50208] [PATCH 3/5] home-services: Add shells.

[Andrew Tropin]

[-- Attachment #1: Type: text/plain, Size: 23567 bytes --]

* gnu/home-services/shells.scm
(home-shell-profile-service-type, home-shell-profile-configuration)
(home-bash-service-type, home-bash-configuration, home-bash-extension)
(home-zsh-service-type, home-zsh-configuration, home-zsh-extension)
(home-fish-service-type, home-fish-configuration, home-fish-extension): New
variables.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add home-services/shells.scm.
---
 gnu/home-services/shells.scm | 637 +++++++++++++++++++++++++++++++++++
 gnu/local.mk                 |   1 +
 2 files changed, 638 insertions(+)
 create mode 100644 gnu/home-services/shells.scm

diff --git a/gnu/home-services/shells.scm b/gnu/home-services/shells.scm
new file mode 100644
index 0000000000..0643019361
--- /dev/null
+++ b/gnu/home-services/shells.scm
@@ -0,0 +1,637 @@
+;;; 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 shells)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu home-services configuration)
+  #:use-module (gnu home-services)
+  #:use-module (gnu packages shells)
+  #:use-module (gnu packages bash)
+  #:use-module (guix gexp)
+  #:use-module (guix packages)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+
+  #:export (home-shell-profile-service-type
+            home-shell-profile-configuration
+
+            home-bash-service-type
+            home-bash-configuration
+            home-bash-extension
+
+            home-zsh-service-type
+            home-zsh-configuration
+            home-zsh-extension
+
+            home-fish-service-type
+            home-fish-configuration
+            home-fish-extension))
+
+;;; Commentary:
+;;;
+;;; This module contains shell related services like Zsh.
+;;;
+;;; Code:
+
+\f
+;;;
+;;; Shell profile.
+;;;
+
+(define path? string?)
+(define (serialize-path field-name val) val)
+
+(define-configuration home-shell-profile-configuration
+  (profile
+   (text-config '())
+   "\
+@code{home-shell-profile} is instantiated automatically by
+@code{home-environment}, DO NOT create this service manually, it can
+only be extended.
+
+@code{profile} is a list of strings or gexps, which will go to
+@file{~/.profile}.  By default @file{~/.profile} contains the
+initialization code, which have to be evaluated by login shell to make
+home-environment's profile avaliable to the user, but other commands
+can be added to the file if it is really necessary.
+
+In most cases shell's configuration files are preferred places for
+user's customizations.  Extend home-shell-profile service only if you
+really know what you do."))
+
+(define (add-shell-profile-file config)
+  `(("profile"
+     ,(mixed-text-file
+       "shell-profile"
+       "\
+HOME_ENVIRONMENT=$HOME/.guix-home
+. $HOME_ENVIRONMENT/setup-environment
+$HOME_ENVIRONMENT/on-first-login\n"
+       (serialize-configuration
+        config
+        (filter-configuration-fields
+         home-shell-profile-configuration-fields '(profile)))))))
+
+(define (add-profile-extensions config extensions)
+  (home-shell-profile-configuration
+   (inherit config)
+   (profile
+    (append (home-shell-profile-configuration-profile config)
+            extensions))))
+
+(define home-shell-profile-service-type
+  (service-type (name 'home-shell-profile)
+                (extensions
+                 (list (service-extension
+                        home-files-service-type
+                        add-shell-profile-file)))
+                (compose concatenate)
+                (extend add-profile-extensions)
+                (default-value (home-shell-profile-configuration))
+                (description "Create @file{~/.profile}, which is used
+for environment initialization of POSIX compliant login shells.  This
+service type can be extended with a list of strings or gexps.")))
+
+(define (serialize-boolean field-name val) "")
+(define (serialize-posix-env-vars field-name val)
+  #~(string-append
+     #$@(map
+         (match-lambda
+           ((key . #f)
+            "")
+           ((key . #t)
+            #~(string-append "export " #$key "\n"))
+           ((key . value)
+            #~(string-append "export " #$key "=" #$value "\n")))
+         val)))
+
+\f
+;;;
+;;; Zsh.
+;;;
+
+(define-configuration home-zsh-configuration
+  (package
+    (package zsh)
+    "The Zsh package to use.")
+  (xdg-flavor?
+   (boolean #t)
+   "Place all the configs to @file{$XDG_CONFIG_HOME/zsh}.  Makes
+@file{~/.zshenv} to set @env{ZDOTDIR} to @file{$XDG_CONFIG_HOME/zsh}.
+Shell startup process will continue with
+@file{$XDG_CONFIG_HOME/zsh/.zshenv}.")
+  (environment-variables
+   (alist '())
+   "Association list of environment variables to set for the Zsh session."
+   serialize-posix-env-vars)
+  (zshenv
+   (text-config '())
+   "List of strings or gexps, which will be added to @file{.zshenv}.
+Used for setting user's shell environment variables.  Must not contain
+commands assuming the presence of tty or producing output.  Will be
+read always.  Will be read before any other file in @env{ZDOTDIR}.")
+  (zprofile
+   (text-config '())
+   "List of strings or gexps, which will be added to @file{.zprofile}.
+Used for executing user's commands at start of login shell (In most
+cases the shell started on tty just after login).  Will be read before
+@file{.zlogin}.")
+  (zshrc
+   (text-config '())
+   "List of strings or gexps, which will be added to @file{.zshrc}.
+Used for executing user's commands at start of interactive shell (The
+shell for interactive usage started by typing @code{zsh} or by
+terminal app or any other program).")
+  (zlogin
+   (text-config '())
+   "List of strings or gexps, which will be added to @file{.zlogin}.
+Used for executing user's commands at the end of starting process of
+login shell.")
+  (zlogout
+   (text-config '())
+   "List of strings or gexps, which will be added to @file{.zlogout}.
+Used for executing user's commands at the exit of login shell.  It
+won't be read in some cases (if the shell terminates by exec'ing
+another process for example)."))
+
+(define (add-zsh-configuration config)
+  (let* ((xdg-flavor? (home-zsh-configuration-xdg-flavor? config)))
+
+    (define prefix-file
+      (cut string-append
+        (if xdg-flavor?
+            "config/zsh/."
+            "") <>))
+
+    (define (filter-fields field)
+      (filter-configuration-fields home-zsh-configuration-fields
+                                   (list field)))
+
+    (define (serialize-field field)
+      (serialize-configuration
+       config
+       (filter-fields field)))
+
+    (define (file-if-not-empty field)
+      (let ((file-name (symbol->string field))
+            (field-obj (car (filter-fields field))))
+        (if (not (null? ((configuration-field-getter field-obj) config)))
+            `(,(prefix-file file-name)
+              ,(mixed-text-file
+                file-name
+                (serialize-field field)))
+            '())))
+
+    (filter
+     (compose not null?)
+     `(,(if xdg-flavor?
+            `("zshenv"
+              ,(mixed-text-file
+                "auxiliary-zshenv"
+                (if xdg-flavor?
+                    "source ${XDG_CONFIG_HOME:-$HOME/.config}/zsh/.zshenv\n"
+                    "")))
+            '())
+       (,(prefix-file "zshenv")
+        ,(mixed-text-file
+          "zshenv"
+          (if xdg-flavor?
+              "export ZDOTDIR=${XDG_CONFIG_HOME:-$HOME/.config}/zsh\n"
+              "")
+          (serialize-field 'zshenv)
+          (serialize-field 'environment-variables)))
+       (,(prefix-file "zprofile")
+        ,(mixed-text-file
+          "zprofile"
+          "\
+# Setups system and user profiles and related variables
+source /etc/profile
+# Setups home environment profile
+source ~/.profile
+
+# It's only necessary if zsh is a login shell, otherwise profiles will
+# be already sourced by bash
+"
+          (serialize-field 'zprofile)))
+
+       ,@(list (file-if-not-empty 'zshrc)
+               (file-if-not-empty 'zlogin)
+               (file-if-not-empty 'zlogout))))))
+
+(define (add-zsh-packages config)
+  (list (home-zsh-configuration-package config)))
+
+(define-configuration/no-serialization home-zsh-extension
+  (environment-variables
+   (alist '())
+   "Association list of environment variables to set.")
+  (zshrc
+   (text-config '())
+   "List of strings or gexps.")
+  (zshenv
+   (text-config '())
+   "List of strings or gexps.")
+  (zprofile
+   (text-config '())
+   "List of strings or gexps.")
+  (zlogin
+   (text-config '())
+   "List of strings or gexps.")
+  (zlogout
+   (text-config '())
+   "List of strings or gexps."))
+
+(define (home-zsh-extensions original-config extension-configs)
+  (home-zsh-configuration
+   (inherit original-config)
+   (environment-variables
+    (append (home-zsh-configuration-environment-variables original-config)
+            (append-map
+             home-zsh-extension-environment-variables extension-configs)))
+   (zshrc
+    (append (home-zsh-configuration-zshrc original-config)
+            (append-map
+             home-zsh-extension-zshrc extension-configs)))
+   (zshenv
+    (append (home-zsh-configuration-zshenv original-config)
+            (append-map
+             home-zsh-extension-zshenv extension-configs)))
+   (zprofile
+    (append (home-zsh-configuration-zprofile original-config)
+            (append-map
+             home-zsh-extension-zprofile extension-configs)))
+   (zlogin
+    (append (home-zsh-configuration-zlogin original-config)
+            (append-map
+             home-zsh-extension-zlogin extension-configs)))
+   (zlogout
+    (append (home-zsh-configuration-zlogout original-config)
+            (append-map
+             home-zsh-extension-zlogout extension-configs)))))
+
+(define home-zsh-service-type
+  (service-type (name 'home-zsh)
+                (extensions
+                 (list (service-extension
+                        home-files-service-type
+                        add-zsh-configuration)
+                       (service-extension
+                        home-profile-service-type
+                        add-zsh-packages)))
+                (compose identity)
+                (extend home-zsh-extensions)
+                (default-value (home-zsh-configuration))
+                (description "Install and configure Zsh.")))
+
+\f
+;;;
+;;; Bash.
+;;;
+
+(define-configuration home-bash-configuration
+  (package
+   (package bash)
+   "The Bash package to use.")
+  (guix-defaults?
+   (boolean #t)
+   "Add sane defaults like reading @file{/etc/bashrc}, coloring output
+for @code{ls} provided by guix to @file{.bashrc}.")
+  (environment-variables
+   (alist '())
+   "Association list of environment variables to set for the Bash session."
+   serialize-posix-env-vars)
+  (bash-profile
+   (text-config '())
+   "List of strings or gexps, which will be added to @file{.bash_profile}.
+Used for executing user's commands at start of login shell (In most
+cases the shell started on tty just after login).  @file{.bash_login}
+won't be ever read, because @file{.bash_profile} always present.")
+  (bashrc
+   (text-config '())
+   "List of strings or gexps, which will be added to @file{.bashrc}.
+Used for executing user's commands at start of interactive shell (The
+shell for interactive usage started by typing @code{bash} or by
+terminal app or any other program).")
+  (bash-logout
+   (text-config '())
+   "List of strings or gexps, which will be added to @file{.bash_logout}.
+Used for executing user's commands at the exit of login shell.  It
+won't be read in some cases (if the shell terminates by exec'ing
+another process for example)."))
+
+;; TODO: Use value from (gnu system shadow)
+(define guix-bashrc
+  "\
+# Bash initialization for interactive non-login shells and
+# for remote shells (info \"(bash) Bash Startup Files\").
+
+# Export 'SHELL' to child processes.  Programs such as 'screen'
+# honor it and otherwise use /bin/sh.
+export SHELL
+
+if [[ $- != *i* ]]
+then
+    # We are being invoked from a non-interactive shell.  If this
+    # is an SSH session (as in \"ssh host command\"), source
+    # /etc/profile so we get PATH and other essential variables.
+    [[ -n \"$SSH_CLIENT\" ]] && source /etc/profile
+
+    # Don't do anything else.
+    return
+fi
+
+# Source the system-wide file.
+source /etc/bashrc
+
+# Adjust the prompt depending on whether we're in 'guix environment'.
+if [ -n \"$GUIX_ENVIRONMENT\" ]
+then
+    PS1='\\u@\\h \\w [env]\\$ '
+else
+    PS1='\\u@\\h \\w\\$ '
+fi
+alias ls='ls -p --color=auto'
+alias ll='ls -l'
+alias grep='grep --color=auto'\n")
+
+(define (add-bash-configuration config)
+  (define (filter-fields field)
+    (filter-configuration-fields home-bash-configuration-fields
+                                 (list field)))
+
+  (define (serialize-field field)
+    (serialize-configuration
+     config
+     (filter-fields field)))
+
+  (define* (file-if-not-empty field #:optional (extra-content #f))
+    (let ((file-name (symbol->string field))
+          (field-obj (car (filter-fields field))))
+      (if (or extra-content
+              (not (null? ((configuration-field-getter field-obj) config))))
+          `(,(object->snake-case-string file-name)
+            ,(mixed-text-file
+              (object->snake-case-string file-name)
+              (if extra-content extra-content "")
+              (serialize-field field)))
+          '())))
+
+  (filter
+   (compose not null?)
+   `(("bash_profile"
+      ,(mixed-text-file
+        "bash_profile"
+        "\
+# Setups system and user profiles and related variables
+# /etc/profile will be sourced by bash automatically
+# Setups home environment profile
+if [ -f ~/.profile ]; then source ~/.profile; fi
+
+# Honor per-interactive-shell startup file
+if [ -f ~/.bashrc ]; then source ~/.bashrc; fi
+"
+        (serialize-field 'bash-profile)
+        (serialize-field 'environment-variables)))
+
+     ,@(list (file-if-not-empty
+              'bashrc
+              (if (home-bash-configuration-guix-defaults? config)
+                  guix-bashrc
+                  #f))
+             (file-if-not-empty 'bash-logout)))))
+
+(define (add-bash-packages config)
+  (list (home-bash-configuration-package config)))
+
+(define-configuration/no-serialization home-bash-extension
+  (environment-variables
+   (alist '())
+   "Association list of environment variables to set.")
+  (bash-profile
+   (text-config '())
+   "List of strings or gexps.")
+  (bashrc
+   (text-config '())
+   "List of strings or gexps.")
+  (bash-logout
+   (text-config '())
+   "List of strings or gexps."))
+
+(define (home-bash-extensions original-config extension-configs)
+  (home-bash-configuration
+   (inherit original-config)
+   (environment-variables
+    (append (home-bash-configuration-environment-variables original-config)
+            (append-map
+             home-bash-extension-environment-variables extension-configs)))
+   (bash-profile
+    (append (home-bash-configuration-bash-profile original-config)
+            (append-map
+             home-bash-extension-bash-profile extension-configs)))
+   (bashrc
+    (append (home-bash-configuration-bashrc original-config)
+            (append-map
+             home-bash-extension-bashrc extension-configs)))
+   (bash-logout
+    (append (home-bash-configuration-bash-logout original-config)
+            (append-map
+             home-bash-extension-bash-logout extension-configs)))))
+
+(define home-bash-service-type
+  (service-type (name 'home-bash)
+                (extensions
+                 (list (service-extension
+                        home-files-service-type
+                        add-bash-configuration)
+                       (service-extension
+                        home-profile-service-type
+                        add-bash-packages)))
+                (compose identity)
+                (extend home-bash-extensions)
+                (default-value (home-bash-configuration))
+                (description "Install and configure GNU Bash.")))
+
+\f
+;;;
+;;; Fish.
+;;;
+
+(define (serialize-fish-aliases field-name val)
+  #~(string-append
+     #$@(map (match-lambda
+               ((key . value)
+                #~(string-append "alias " #$key " \"" #$value "\"\n"))
+               (_ ""))
+             val)))
+
+(define (serialize-fish-abbreviations field-name val)
+  #~(string-append
+     #$@(map (match-lambda
+               ((key . value)
+                #~(string-append "abbr --add " #$key " " #$value "\n"))
+               (_ ""))
+             val)))
+
+(define (serialize-fish-env-vars field-name val)
+  #~(string-append
+     #$@(map (match-lambda
+               ((key . #f)
+                "")
+               ((key . #t)
+                #~(string-append "set " #$key "\n"))
+               ((key . value)
+                #~(string-append "set " #$key " "  #$value "\n")))
+             val)))
+
+(define-configuration home-fish-configuration
+  (package
+    (package fish)
+    "The Fish package to use.")
+  (config
+   (text-config '())
+   "List of strings or gexps, which will be added to
+@file{$XDG_CONFIG_HOME/fish/config.fish}.")
+  (environment-variables
+   (alist '())
+   "Association list of environment variables to set in Fish."
+   serialize-fish-env-vars)
+  (aliases
+   (alist '())
+   "Association list of aliases for Fish, both the key and the value
+should be a string.  An alias is just a simple function that wraps a
+command, If you want something more akin to @dfn{aliases} in POSIX
+shells, see the @code{abbreviations} field."
+   serialize-fish-aliases)
+  (abbreviations
+   (alist '())
+   "Association list of abbreviations for Fish.  These are words that,
+when typed in the shell, will automatically expand to the full text."
+   serialize-fish-abbreviations))
+
+(define (fish-files-service config)
+  `(("config/fish/config.fish"
+     ,(mixed-text-file
+       "fish-config.fish"
+       #~(string-append "\
+# if we haven't sourced the login config, do it
+status --is-login; and not set -q __fish_login_config_sourced
+and begin
+
+  set --prepend fish_function_path "
+                        #$fish-foreign-env
+                        "/share/fish/functions
+  fenv source $HOME/.profile
+  set -e fish_function_path[1]
+
+  set -g __fish_login_config_sourced 1
+
+end\n\n")
+       (serialize-configuration
+        config
+        home-fish-configuration-fields)))))
+
+(define (fish-profile-service config)
+  (list (home-fish-configuration-package config)))
+
+(define-configuration/no-serialization home-fish-extension
+  (config
+   (text-config '())
+   "List of strings or gexps for extending the Fish initialization file.")
+  (environment-variables
+   (alist '())
+   "Association list of environment variables to set.")
+  (aliases
+   (alist '())
+   "Association list of Fish aliases.")
+  (abbreviations
+   (alist '())
+   "Association list of Fish abbreviations."))
+
+(define (home-fish-extensions original-config extension-configs)
+  (home-fish-configuration
+   (inherit original-config)
+   (config
+    (append (home-fish-configuration-config original-config)
+            (append-map
+             home-fish-extension-config extension-configs)))
+   (environment-variables
+    (append (home-fish-configuration-environment-variables original-config)
+            (append-map
+             home-fish-extension-environment-variables extension-configs)))
+   (aliases
+    (append (home-fish-configuration-aliases original-config)
+            (append-map
+             home-fish-extension-aliases extension-configs)))
+   (abbreviations
+    (append (home-fish-configuration-abbreviations original-config)
+            (append-map
+             home-fish-extension-abbreviations extension-configs)))))
+
+;; TODO: Support for generating completion files
+;; TODO: Support for installing plugins
+(define home-fish-service-type
+  (service-type (name 'home-fish)
+                (extensions
+                 (list (service-extension
+                        home-files-service-type
+                        fish-files-service)
+                       (service-extension
+                        home-profile-service-type
+                        fish-profile-service)))
+                (compose identity)
+                (extend home-fish-extensions)
+                (default-value (home-fish-configuration))
+                (description "\
+Install and configure Fish, the friendly interactive shell.")))
+
+
+(define (generate-home-shell-profile-documentation)
+  (generate-documentation
+   `((home-shell-profile-configuration
+      ,home-shell-profile-configuration-fields))
+   'home-shell-profile-configuration))
+
+(define (generate-home-bash-documentation)
+  (generate-documentation
+   `((home-bash-configuration
+      ,home-bash-configuration-fields))
+   'home-bash-configuration))
+
+(define (generate-home-zsh-documentation)
+  (generate-documentation
+   `((home-zsh-configuration
+      ,home-zsh-configuration-fields))
+   'home-zsh-configuration))
+
+(define (generate-home-fish-documentation)
+  (string-append
+   (generate-documentation
+    `((home-fish-configuration
+       ,home-fish-configuration-fields))
+    'home-fish-configuration)
+   "\n\n"
+   (generate-documentation
+    `((home-fish-extension
+       ,home-fish-extension-fields))
+    'home-fish-extension)))
+
+;; (display (generate-home-shell-profile-documentation))
+;; (display (generate-home-bash-documentation))
+;; (display (generate-home-zsh-documentation))
diff --git a/gnu/local.mk b/gnu/local.mk
index e24da4716f..dc0e732114 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -76,6 +76,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/home-services/symlink-manager.scm         \
   %D%/home-services/fontutils.scm               \
   %D%/home-services/configuration.scm           \
+  %D%/home-services/shells.scm                  \
   %D%/image.scm					\
   %D%/packages.scm				\
   %D%/packages/abduco.scm			\
-- 
2.33.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 853 bytes --]

[bug#50208] [PATCH 3/5] home-services: Add shells.

[Andrew Tropin]

[-- Attachment #1: Type: text/plain, Size: 25025 bytes --]

On 2021-08-27 10:03, Andrew Tropin wrote:

> * gnu/home-services/shells.scm
> (home-shell-profile-service-type, home-shell-profile-configuration)
> (home-bash-service-type, home-bash-configuration, home-bash-extension)
> (home-zsh-service-type, home-zsh-configuration, home-zsh-extension)
> (home-fish-service-type, home-fish-configuration, home-fish-extension): New
> variables.
> * gnu/local.mk (GNU_SYSTEM_MODULES): Add home-services/shells.scm.
> ---
>  gnu/home-services/shells.scm | 637 +++++++++++++++++++++++++++++++++++
>  gnu/local.mk                 |   1 +
>  2 files changed, 638 insertions(+)
>  create mode 100644 gnu/home-services/shells.scm
>
> diff --git a/gnu/home-services/shells.scm b/gnu/home-services/shells.scm
> new file mode 100644
> index 0000000000..0643019361
> --- /dev/null
> +++ b/gnu/home-services/shells.scm
> @@ -0,0 +1,637 @@
> +;;; 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 shells)
> +  #:use-module (gnu services configuration)
> +  #:use-module (gnu home-services configuration)
> +  #:use-module (gnu home-services)
> +  #:use-module (gnu packages shells)
> +  #:use-module (gnu packages bash)
> +  #:use-module (guix gexp)
> +  #:use-module (guix packages)
> +  #:use-module (srfi srfi-1)
> +  #:use-module (srfi srfi-26)
> +  #:use-module (ice-9 match)
> +
> +  #:export (home-shell-profile-service-type
> +            home-shell-profile-configuration
> +
> +            home-bash-service-type
> +            home-bash-configuration
> +            home-bash-extension
> +
> +            home-zsh-service-type
> +            home-zsh-configuration
> +            home-zsh-extension
> +
> +            home-fish-service-type
> +            home-fish-configuration
> +            home-fish-extension))
> +
> +;;; Commentary:
> +;;;
> +;;; This module contains shell related services like Zsh.
> +;;;
> +;;; Code:
> +
> +\f
> +;;;
> +;;; Shell profile.
> +;;;
> +
> +(define path? string?)
> +(define (serialize-path field-name val) val)
> +
> +(define-configuration home-shell-profile-configuration
> +  (profile
> +   (text-config '())
> +   "\
> +@code{home-shell-profile} is instantiated automatically by
> +@code{home-environment}, DO NOT create this service manually, it can
> +only be extended.
> +
> +@code{profile} is a list of strings or gexps, which will go to
> +@file{~/.profile}.  By default @file{~/.profile} contains the
> +initialization code, which have to be evaluated by login shell to make
> +home-environment's profile avaliable to the user, but other commands
> +can be added to the file if it is really necessary.
> +
> +In most cases shell's configuration files are preferred places for
> +user's customizations.  Extend home-shell-profile service only if you
> +really know what you do."))
> +
> +(define (add-shell-profile-file config)
> +  `(("profile"
> +     ,(mixed-text-file
> +       "shell-profile"
> +       "\
> +HOME_ENVIRONMENT=$HOME/.guix-home
> +. $HOME_ENVIRONMENT/setup-environment
> +$HOME_ENVIRONMENT/on-first-login\n"
> +       (serialize-configuration
> +        config
> +        (filter-configuration-fields
> +         home-shell-profile-configuration-fields '(profile)))))))
> +
> +(define (add-profile-extensions config extensions)
> +  (home-shell-profile-configuration
> +   (inherit config)
> +   (profile
> +    (append (home-shell-profile-configuration-profile config)
> +            extensions))))
> +
> +(define home-shell-profile-service-type
> +  (service-type (name 'home-shell-profile)
> +                (extensions
> +                 (list (service-extension
> +                        home-files-service-type
> +                        add-shell-profile-file)))
> +                (compose concatenate)
> +                (extend add-profile-extensions)
> +                (default-value (home-shell-profile-configuration))
> +                (description "Create @file{~/.profile}, which is used
> +for environment initialization of POSIX compliant login shells.  This
> +service type can be extended with a list of strings or gexps.")))
> +
> +(define (serialize-boolean field-name val) "")
> +(define (serialize-posix-env-vars field-name val)
> +  #~(string-append
> +     #$@(map
> +         (match-lambda
> +           ((key . #f)
> +            "")
> +           ((key . #t)
> +            #~(string-append "export " #$key "\n"))
> +           ((key . value)
> +            #~(string-append "export " #$key "=" #$value "\n")))
> +         val)))
> +
> +\f
> +;;;
> +;;; Zsh.
> +;;;
> +
> +(define-configuration home-zsh-configuration
> +  (package
> +    (package zsh)
> +    "The Zsh package to use.")
> +  (xdg-flavor?
> +   (boolean #t)
> +   "Place all the configs to @file{$XDG_CONFIG_HOME/zsh}.  Makes
> +@file{~/.zshenv} to set @env{ZDOTDIR} to @file{$XDG_CONFIG_HOME/zsh}.
> +Shell startup process will continue with
> +@file{$XDG_CONFIG_HOME/zsh/.zshenv}.")
> +  (environment-variables
> +   (alist '())
> +   "Association list of environment variables to set for the Zsh session."
> +   serialize-posix-env-vars)
> +  (zshenv
> +   (text-config '())
> +   "List of strings or gexps, which will be added to @file{.zshenv}.
> +Used for setting user's shell environment variables.  Must not contain
> +commands assuming the presence of tty or producing output.  Will be
> +read always.  Will be read before any other file in @env{ZDOTDIR}.")
> +  (zprofile
> +   (text-config '())
> +   "List of strings or gexps, which will be added to @file{.zprofile}.
> +Used for executing user's commands at start of login shell (In most
> +cases the shell started on tty just after login).  Will be read before
> +@file{.zlogin}.")
> +  (zshrc
> +   (text-config '())
> +   "List of strings or gexps, which will be added to @file{.zshrc}.
> +Used for executing user's commands at start of interactive shell (The
> +shell for interactive usage started by typing @code{zsh} or by
> +terminal app or any other program).")
> +  (zlogin
> +   (text-config '())
> +   "List of strings or gexps, which will be added to @file{.zlogin}.
> +Used for executing user's commands at the end of starting process of
> +login shell.")
> +  (zlogout
> +   (text-config '())
> +   "List of strings or gexps, which will be added to @file{.zlogout}.
> +Used for executing user's commands at the exit of login shell.  It
> +won't be read in some cases (if the shell terminates by exec'ing
> +another process for example)."))
> +
> +(define (add-zsh-configuration config)
> +  (let* ((xdg-flavor? (home-zsh-configuration-xdg-flavor? config)))
> +
> +    (define prefix-file
> +      (cut string-append
> +        (if xdg-flavor?
> +            "config/zsh/."
> +            "") <>))
> +
> +    (define (filter-fields field)
> +      (filter-configuration-fields home-zsh-configuration-fields
> +                                   (list field)))
> +
> +    (define (serialize-field field)
> +      (serialize-configuration
> +       config
> +       (filter-fields field)))
> +
> +    (define (file-if-not-empty field)
> +      (let ((file-name (symbol->string field))
> +            (field-obj (car (filter-fields field))))
> +        (if (not (null? ((configuration-field-getter field-obj) config)))
> +            `(,(prefix-file file-name)
> +              ,(mixed-text-file
> +                file-name
> +                (serialize-field field)))
> +            '())))
> +
> +    (filter
> +     (compose not null?)
> +     `(,(if xdg-flavor?
> +            `("zshenv"
> +              ,(mixed-text-file
> +                "auxiliary-zshenv"
> +                (if xdg-flavor?
> +                    "source ${XDG_CONFIG_HOME:-$HOME/.config}/zsh/.zshenv\n"
> +                    "")))
> +            '())
> +       (,(prefix-file "zshenv")
> +        ,(mixed-text-file
> +          "zshenv"
> +          (if xdg-flavor?
> +              "export ZDOTDIR=${XDG_CONFIG_HOME:-$HOME/.config}/zsh\n"
> +              "")
> +          (serialize-field 'zshenv)
> +          (serialize-field 'environment-variables)))
> +       (,(prefix-file "zprofile")
> +        ,(mixed-text-file
> +          "zprofile"
> +          "\
> +# Setups system and user profiles and related variables
> +source /etc/profile
> +# Setups home environment profile
> +source ~/.profile
> +
> +# It's only necessary if zsh is a login shell, otherwise profiles will
> +# be already sourced by bash
> +"
> +          (serialize-field 'zprofile)))
> +
> +       ,@(list (file-if-not-empty 'zshrc)
> +               (file-if-not-empty 'zlogin)
> +               (file-if-not-empty 'zlogout))))))
> +
> +(define (add-zsh-packages config)
> +  (list (home-zsh-configuration-package config)))
> +
> +(define-configuration/no-serialization home-zsh-extension
> +  (environment-variables
> +   (alist '())
> +   "Association list of environment variables to set.")
> +  (zshrc
> +   (text-config '())
> +   "List of strings or gexps.")
> +  (zshenv
> +   (text-config '())
> +   "List of strings or gexps.")
> +  (zprofile
> +   (text-config '())
> +   "List of strings or gexps.")
> +  (zlogin
> +   (text-config '())
> +   "List of strings or gexps.")
> +  (zlogout
> +   (text-config '())
> +   "List of strings or gexps."))
> +
> +(define (home-zsh-extensions original-config extension-configs)
> +  (home-zsh-configuration
> +   (inherit original-config)
> +   (environment-variables
> +    (append (home-zsh-configuration-environment-variables original-config)
> +            (append-map
> +             home-zsh-extension-environment-variables extension-configs)))
> +   (zshrc
> +    (append (home-zsh-configuration-zshrc original-config)
> +            (append-map
> +             home-zsh-extension-zshrc extension-configs)))
> +   (zshenv
> +    (append (home-zsh-configuration-zshenv original-config)
> +            (append-map
> +             home-zsh-extension-zshenv extension-configs)))
> +   (zprofile
> +    (append (home-zsh-configuration-zprofile original-config)
> +            (append-map
> +             home-zsh-extension-zprofile extension-configs)))
> +   (zlogin
> +    (append (home-zsh-configuration-zlogin original-config)
> +            (append-map
> +             home-zsh-extension-zlogin extension-configs)))
> +   (zlogout
> +    (append (home-zsh-configuration-zlogout original-config)
> +            (append-map
> +             home-zsh-extension-zlogout extension-configs)))))
> +
> +(define home-zsh-service-type
> +  (service-type (name 'home-zsh)
> +                (extensions
> +                 (list (service-extension
> +                        home-files-service-type
> +                        add-zsh-configuration)
> +                       (service-extension
> +                        home-profile-service-type
> +                        add-zsh-packages)))
> +                (compose identity)
> +                (extend home-zsh-extensions)
> +                (default-value (home-zsh-configuration))
> +                (description "Install and configure Zsh.")))
> +
> +\f
> +;;;
> +;;; Bash.
> +;;;
> +
> +(define-configuration home-bash-configuration
> +  (package
> +   (package bash)
> +   "The Bash package to use.")
> +  (guix-defaults?
> +   (boolean #t)
> +   "Add sane defaults like reading @file{/etc/bashrc}, coloring output
> +for @code{ls} provided by guix to @file{.bashrc}.")
> +  (environment-variables
> +   (alist '())
> +   "Association list of environment variables to set for the Bash session."
> +   serialize-posix-env-vars)
> +  (bash-profile
> +   (text-config '())
> +   "List of strings or gexps, which will be added to @file{.bash_profile}.
> +Used for executing user's commands at start of login shell (In most
> +cases the shell started on tty just after login).  @file{.bash_login}
> +won't be ever read, because @file{.bash_profile} always present.")
> +  (bashrc
> +   (text-config '())
> +   "List of strings or gexps, which will be added to @file{.bashrc}.
> +Used for executing user's commands at start of interactive shell (The
> +shell for interactive usage started by typing @code{bash} or by
> +terminal app or any other program).")
> +  (bash-logout
> +   (text-config '())
> +   "List of strings or gexps, which will be added to @file{.bash_logout}.
> +Used for executing user's commands at the exit of login shell.  It
> +won't be read in some cases (if the shell terminates by exec'ing
> +another process for example)."))
> +
> +;; TODO: Use value from (gnu system shadow)
> +(define guix-bashrc
> +  "\
> +# Bash initialization for interactive non-login shells and
> +# for remote shells (info \"(bash) Bash Startup Files\").
> +
> +# Export 'SHELL' to child processes.  Programs such as 'screen'
> +# honor it and otherwise use /bin/sh.
> +export SHELL
> +
> +if [[ $- != *i* ]]
> +then
> +    # We are being invoked from a non-interactive shell.  If this
> +    # is an SSH session (as in \"ssh host command\"), source
> +    # /etc/profile so we get PATH and other essential variables.
> +    [[ -n \"$SSH_CLIENT\" ]] && source /etc/profile
> +
> +    # Don't do anything else.
> +    return
> +fi
> +
> +# Source the system-wide file.
> +source /etc/bashrc
> +
> +# Adjust the prompt depending on whether we're in 'guix environment'.
> +if [ -n \"$GUIX_ENVIRONMENT\" ]
> +then
> +    PS1='\\u@\\h \\w [env]\\$ '
> +else
> +    PS1='\\u@\\h \\w\\$ '
> +fi
> +alias ls='ls -p --color=auto'
> +alias ll='ls -l'
> +alias grep='grep --color=auto'\n")
> +
> +(define (add-bash-configuration config)
> +  (define (filter-fields field)
> +    (filter-configuration-fields home-bash-configuration-fields
> +                                 (list field)))
> +
> +  (define (serialize-field field)
> +    (serialize-configuration
> +     config
> +     (filter-fields field)))
> +
> +  (define* (file-if-not-empty field #:optional (extra-content #f))
> +    (let ((file-name (symbol->string field))
> +          (field-obj (car (filter-fields field))))
> +      (if (or extra-content
> +              (not (null? ((configuration-field-getter field-obj) config))))
> +          `(,(object->snake-case-string file-name)

Didn't add object->snake-case-string function to this patch series, will
add it in v2.

> +            ,(mixed-text-file
> +              (object->snake-case-string file-name)
> +              (if extra-content extra-content "")
> +              (serialize-field field)))
> +          '())))
> +
> +  (filter
> +   (compose not null?)
> +   `(("bash_profile"
> +      ,(mixed-text-file
> +        "bash_profile"
> +        "\
> +# Setups system and user profiles and related variables
> +# /etc/profile will be sourced by bash automatically
> +# Setups home environment profile
> +if [ -f ~/.profile ]; then source ~/.profile; fi
> +
> +# Honor per-interactive-shell startup file
> +if [ -f ~/.bashrc ]; then source ~/.bashrc; fi
> +"
> +        (serialize-field 'bash-profile)
> +        (serialize-field 'environment-variables)))
> +
> +     ,@(list (file-if-not-empty
> +              'bashrc
> +              (if (home-bash-configuration-guix-defaults? config)
> +                  guix-bashrc
> +                  #f))
> +             (file-if-not-empty 'bash-logout)))))
> +
> +(define (add-bash-packages config)
> +  (list (home-bash-configuration-package config)))
> +
> +(define-configuration/no-serialization home-bash-extension
> +  (environment-variables
> +   (alist '())
> +   "Association list of environment variables to set.")
> +  (bash-profile
> +   (text-config '())
> +   "List of strings or gexps.")
> +  (bashrc
> +   (text-config '())
> +   "List of strings or gexps.")
> +  (bash-logout
> +   (text-config '())
> +   "List of strings or gexps."))
> +
> +(define (home-bash-extensions original-config extension-configs)
> +  (home-bash-configuration
> +   (inherit original-config)
> +   (environment-variables
> +    (append (home-bash-configuration-environment-variables original-config)
> +            (append-map
> +             home-bash-extension-environment-variables extension-configs)))
> +   (bash-profile
> +    (append (home-bash-configuration-bash-profile original-config)
> +            (append-map
> +             home-bash-extension-bash-profile extension-configs)))
> +   (bashrc
> +    (append (home-bash-configuration-bashrc original-config)
> +            (append-map
> +             home-bash-extension-bashrc extension-configs)))
> +   (bash-logout
> +    (append (home-bash-configuration-bash-logout original-config)
> +            (append-map
> +             home-bash-extension-bash-logout extension-configs)))))
> +
> +(define home-bash-service-type
> +  (service-type (name 'home-bash)
> +                (extensions
> +                 (list (service-extension
> +                        home-files-service-type
> +                        add-bash-configuration)
> +                       (service-extension
> +                        home-profile-service-type
> +                        add-bash-packages)))
> +                (compose identity)
> +                (extend home-bash-extensions)
> +                (default-value (home-bash-configuration))
> +                (description "Install and configure GNU Bash.")))
> +
> +\f
> +;;;
> +;;; Fish.
> +;;;
> +
> +(define (serialize-fish-aliases field-name val)
> +  #~(string-append
> +     #$@(map (match-lambda
> +               ((key . value)
> +                #~(string-append "alias " #$key " \"" #$value "\"\n"))
> +               (_ ""))
> +             val)))
> +
> +(define (serialize-fish-abbreviations field-name val)
> +  #~(string-append
> +     #$@(map (match-lambda
> +               ((key . value)
> +                #~(string-append "abbr --add " #$key " " #$value "\n"))
> +               (_ ""))
> +             val)))
> +
> +(define (serialize-fish-env-vars field-name val)
> +  #~(string-append
> +     #$@(map (match-lambda
> +               ((key . #f)
> +                "")
> +               ((key . #t)
> +                #~(string-append "set " #$key "\n"))
> +               ((key . value)
> +                #~(string-append "set " #$key " "  #$value "\n")))
> +             val)))
> +
> +(define-configuration home-fish-configuration
> +  (package
> +    (package fish)
> +    "The Fish package to use.")
> +  (config
> +   (text-config '())
> +   "List of strings or gexps, which will be added to
> +@file{$XDG_CONFIG_HOME/fish/config.fish}.")
> +  (environment-variables
> +   (alist '())
> +   "Association list of environment variables to set in Fish."
> +   serialize-fish-env-vars)
> +  (aliases
> +   (alist '())
> +   "Association list of aliases for Fish, both the key and the value
> +should be a string.  An alias is just a simple function that wraps a
> +command, If you want something more akin to @dfn{aliases} in POSIX
> +shells, see the @code{abbreviations} field."
> +   serialize-fish-aliases)
> +  (abbreviations
> +   (alist '())
> +   "Association list of abbreviations for Fish.  These are words that,
> +when typed in the shell, will automatically expand to the full text."
> +   serialize-fish-abbreviations))
> +
> +(define (fish-files-service config)
> +  `(("config/fish/config.fish"
> +     ,(mixed-text-file
> +       "fish-config.fish"
> +       #~(string-append "\
> +# if we haven't sourced the login config, do it
> +status --is-login; and not set -q __fish_login_config_sourced
> +and begin
> +
> +  set --prepend fish_function_path "
> +                        #$fish-foreign-env
> +                        "/share/fish/functions
> +  fenv source $HOME/.profile
> +  set -e fish_function_path[1]
> +
> +  set -g __fish_login_config_sourced 1
> +
> +end\n\n")
> +       (serialize-configuration
> +        config
> +        home-fish-configuration-fields)))))
> +
> +(define (fish-profile-service config)
> +  (list (home-fish-configuration-package config)))
> +
> +(define-configuration/no-serialization home-fish-extension
> +  (config
> +   (text-config '())
> +   "List of strings or gexps for extending the Fish initialization file.")
> +  (environment-variables
> +   (alist '())
> +   "Association list of environment variables to set.")
> +  (aliases
> +   (alist '())
> +   "Association list of Fish aliases.")
> +  (abbreviations
> +   (alist '())
> +   "Association list of Fish abbreviations."))
> +
> +(define (home-fish-extensions original-config extension-configs)
> +  (home-fish-configuration
> +   (inherit original-config)
> +   (config
> +    (append (home-fish-configuration-config original-config)
> +            (append-map
> +             home-fish-extension-config extension-configs)))
> +   (environment-variables
> +    (append (home-fish-configuration-environment-variables original-config)
> +            (append-map
> +             home-fish-extension-environment-variables extension-configs)))
> +   (aliases
> +    (append (home-fish-configuration-aliases original-config)
> +            (append-map
> +             home-fish-extension-aliases extension-configs)))
> +   (abbreviations
> +    (append (home-fish-configuration-abbreviations original-config)
> +            (append-map
> +             home-fish-extension-abbreviations extension-configs)))))
> +
> +;; TODO: Support for generating completion files
> +;; TODO: Support for installing plugins
> +(define home-fish-service-type
> +  (service-type (name 'home-fish)
> +                (extensions
> +                 (list (service-extension
> +                        home-files-service-type
> +                        fish-files-service)
> +                       (service-extension
> +                        home-profile-service-type
> +                        fish-profile-service)))
> +                (compose identity)
> +                (extend home-fish-extensions)
> +                (default-value (home-fish-configuration))
> +                (description "\
> +Install and configure Fish, the friendly interactive shell.")))
> +
> +
> +(define (generate-home-shell-profile-documentation)
> +  (generate-documentation
> +   `((home-shell-profile-configuration
> +      ,home-shell-profile-configuration-fields))
> +   'home-shell-profile-configuration))
> +
> +(define (generate-home-bash-documentation)
> +  (generate-documentation
> +   `((home-bash-configuration
> +      ,home-bash-configuration-fields))
> +   'home-bash-configuration))
> +
> +(define (generate-home-zsh-documentation)
> +  (generate-documentation
> +   `((home-zsh-configuration
> +      ,home-zsh-configuration-fields))
> +   'home-zsh-configuration))
> +
> +(define (generate-home-fish-documentation)
> +  (string-append
> +   (generate-documentation
> +    `((home-fish-configuration
> +       ,home-fish-configuration-fields))
> +    'home-fish-configuration)
> +   "\n\n"
> +   (generate-documentation
> +    `((home-fish-extension
> +       ,home-fish-extension-fields))
> +    'home-fish-extension)))
> +
> +;; (display (generate-home-shell-profile-documentation))
> +;; (display (generate-home-bash-documentation))
> +;; (display (generate-home-zsh-documentation))
> diff --git a/gnu/local.mk b/gnu/local.mk
> index e24da4716f..dc0e732114 100644
> --- a/gnu/local.mk
> +++ b/gnu/local.mk
> @@ -76,6 +76,7 @@ GNU_SYSTEM_MODULES =				\
>    %D%/home-services/symlink-manager.scm         \
>    %D%/home-services/fontutils.scm               \
>    %D%/home-services/configuration.scm           \
> +  %D%/home-services/shells.scm                  \
>    %D%/image.scm					\
>    %D%/packages.scm				\
>    %D%/packages/abduco.scm			\

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#50208] [PATCH 4/5] home-services: Add xdg.

[Andrew Tropin]

[-- Attachment #1: Type: text/plain, Size: 20462 bytes --]

* gnu/home-services/xdg.scm
(home-xdg-base-directories-service-type)
(home-xdg-base-directories-configuration)
(home-xdg-base-directories-configuration?)
(home-xdg-user-directories-service-type)
(home-xdg-user-directories-configuration)
(home-xdg-user-directories-configuration?)
(xdg-desktop-action, xdg-desktop-entry)
(home-xdg-mime-applications-service-type)
(home-xdg-mime-applications-configuration): New variables.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add home-services/xdg.scm.
---
 gnu/home-services/xdg.scm | 475 ++++++++++++++++++++++++++++++++++++++
 gnu/local.mk              |   1 +
 2 files changed, 476 insertions(+)
 create mode 100644 gnu/home-services/xdg.scm

diff --git a/gnu/home-services/xdg.scm b/gnu/home-services/xdg.scm
new file mode 100644
index 0000000000..acacaa1218
--- /dev/null
+++ b/gnu/home-services/xdg.scm
@@ -0,0 +1,475 @@
+;;; 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 xdg)
+  #:use-module (gnu services configuration)
+  #:use-module (gnu home-services configuration)
+  #:use-module (gnu home-services)
+  #:use-module (gnu packages freedesktop)
+  #:use-module (gnu home-services-utils)
+  #:use-module (guix gexp)
+  #:use-module (guix records)
+  #:use-module (guix i18n)
+
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (rnrs enums)
+
+  #:export (home-xdg-base-directories-service-type
+            home-xdg-base-directories-configuration
+            home-xdg-base-directories-configuration?
+
+            home-xdg-user-directories-service-type
+            home-xdg-user-directories-configuration
+            home-xdg-user-directories-configuration?
+
+            xdg-desktop-action
+            xdg-desktop-entry
+            home-xdg-mime-applications-service-type
+            home-xdg-mime-applications-configuration))
+
+;;; Commentary:
+;;
+;; This module contains services related to XDG directories and
+;; applications.
+;;
+;; - XDG base directories
+;; - XDG user directories
+;; - XDG MIME applications
+;;
+;;; Code:
+
+\f
+;;;
+;;; XDG base directories.
+;;;
+
+(define (serialize-path field-name val) "")
+(define path? string?)
+
+(define-configuration home-xdg-base-directories-configuration
+  (cache-home
+   (path "$HOME/.cache")
+   "Base directory for programs to store user-specific non-essential
+(cached) data.  Files in this directory can be deleted anytime without
+loss of important data.")
+  (config-home
+   (path "$HOME/.config")
+   "Base directory for programs to store configuration files.
+Some programs store here log or state files, but it's not desired,
+this directory should contain static configurations.")
+  (data-home
+   (path "$HOME/.local/share")
+   "Base directory for programs to store architecture independent
+read-only shared data, analogus to @file{/usr/share}, but for user.")
+  (runtime-dir
+   (path "${XDG_RUNTIME_DIR:-/run/user/$UID}")
+   "Base directory for programs to store user-specific runtime files,
+like sockets.")
+  (log-home
+   (path "$HOME/.local/var/log")
+   "Base directory for programs to store log files, analogus to
+@file{/var/log}, but for user.  It is not a part of XDG Base Directory
+Specification, but helps to make implementation of home services more
+consistent.")
+  (state-home
+   (path "$HOME/.local/var/lib")
+   "Base directory for programs to store state files, like databases,
+analogus to @file{/var/lib}, but for user.  It is not a part of XDG
+Base Directory Specification, but helps to make implementation of home
+services more consistent."))
+
+(define (home-xdg-base-directories-environment-variables-service config)
+  (map
+   (lambda (field)
+     (cons (format
+            #f "XDG_~a"
+            (object->snake-case-string (configuration-field-name field) 'upper))
+           ((configuration-field-getter field) config)))
+   home-xdg-base-directories-configuration-fields))
+
+(define (ensure-xdg-base-dirs-on-activation config)
+  #~(map (lambda (xdg-base-dir-variable)
+           ((@@ (guix build utils) mkdir-p)
+            (getenv
+             xdg-base-dir-variable)))
+         '#$(map (lambda (field)
+                   (format
+                    #f "XDG_~a"
+                    (object->snake-case-string
+                     (configuration-field-name field) 'upper)))
+                 home-xdg-base-directories-configuration-fields)))
+
+(define (last-extension-or-cfg config extensions)
+  "Picks configuration value from last provided extension.  If there
+are no extensions use configuration instead."
+  (or (and (not (null? extensions)) (last extensions)) config))
+
+(define home-xdg-base-directories-service-type
+  (service-type (name 'home-xdg-base-directories)
+                (extensions
+                 (list (service-extension
+                        home-environment-variables-service-type
+                        home-xdg-base-directories-environment-variables-service)
+                       (service-extension
+                        home-activation-service-type
+                        ensure-xdg-base-dirs-on-activation)))
+                (default-value (home-xdg-base-directories-configuration))
+                (compose identity)
+                (extend last-extension-or-cfg)
+                (description "Configure XDG base directories.  This
+service introduces two additional variables @env{XDG_STATE_HOME},
+@env{XDG_LOG_HOME}.  They are not a part of XDG specification, at
+least yet, but are convinient to have, it improves the consistency
+between different home services.  The services of this service-type is
+instantiated by default, to provide non-default value, extend the
+service-type (using @code{simple-service} for example).")))
+
+(define (generate-home-xdg-base-directories-documentation)
+  (generate-documentation
+   `((home-xdg-base-directories-configuration
+      ,home-xdg-base-directories-configuration-fields))
+   'home-xdg-base-directories-configuration))
+
+\f
+;;;
+;;; XDG user directories.
+;;;
+
+(define (serialize-string field-name val)
+  ;; The path has to be quoted
+  (format #f "XDG_~a_DIR=\"~a\"\n"
+          (object->snake-case-string field-name 'upper) val))
+
+(define-configuration home-xdg-user-directories-configuration
+  (desktop
+   (string "$HOME/Desktop")
+   "Default ``desktop'' directory, this is what you see on your
+desktop when using a desktop environment,
+e.g. GNOME (@pxref{XWindow,,,guix.info}).")
+  (documents
+   (string "$HOME/Documents")
+   "Default directory to put documents like PDFs.")
+  (download
+   (string "$HOME/Downloads")
+   "Default directory downloaded files, this is where your Web-broser
+will put downloaded files in.")
+  (music
+   (string "$HOME/Music")
+   "Default directory for audio files.")
+  (pictures
+   (string "$HOME/Pictures")
+   "Default directory for pictures and images.")
+  (publicshare
+   (string "$HOME/Public")
+   "Default directory for shared files, which can be accessed by other
+users on local machine or via network.")
+  (templates
+   (string "$HOME/Templates")
+   "Default directory for templates.  They can be used by graphical
+file manager or other apps for creating new files with some
+pre-populated content.")
+  (videos
+   (string "$HOME/Videos")
+   "Default directory for videos."))
+
+(define (home-xdg-user-directories-files-service config)
+  `(("config/user-dirs.conf"
+     ,(mixed-text-file
+       "user-dirs.conf"
+       "enabled=False\n"))
+    ("config/user-dirs.dirs"
+     ,(mixed-text-file
+       "user-dirs.dirs"
+      (serialize-configuration
+       config
+       home-xdg-user-directories-configuration-fields)))))
+
+(define (home-xdg-user-directories-activation-service config)
+  (let ((dirs (map (lambda (field)
+                     ((configuration-field-getter field) config))
+                   home-xdg-user-directories-configuration-fields)))
+    #~(let ((ensure-dir
+             (lambda (path)
+               (mkdir-p
+                ((@@ (ice-9 string-fun) string-replace-substring)
+                 path "$HOME" (getenv "HOME"))))))
+        (display "Creating XDG user directories...")
+        (map ensure-dir '#$dirs)
+        (display " done\n"))))
+
+(define home-xdg-user-directories-service-type
+  (service-type (name 'home-xdg-user-directories)
+                (extensions
+                 (list (service-extension
+                        home-files-service-type
+                        home-xdg-user-directories-files-service)
+                       (service-extension
+                        home-activation-service-type
+                        home-xdg-user-directories-activation-service)))
+                (default-value (home-xdg-user-directories-configuration))
+                (description "Configure XDG user directories.  To
+disable a directory, point it to the $HOME.")))
+
+(define (generate-home-xdg-user-directories-documentation)
+  (generate-documentation
+   `((home-xdg-user-directories-configuration
+     ,home-xdg-user-directories-configuration-fields))
+   'home-xdg-user-directories-configuration))
+
+\f
+;;;
+;;; XDG MIME applications.
+;;;
+
+;; Example config
+;;
+;;  (home-xdg-mime-applications-configuration
+;;   (added '((x-scheme-handler/magnet . torrent.desktop)))
+;;   (default '((inode/directory . file.desktop)))
+;;   (removed '((inode/directory . thunar.desktop)))
+;;   (desktop-entries
+;;    (list (xdg-desktop-entry
+;;           (file "file")
+;;           (name "File manager")
+;;           (type 'application)
+;;           (config
+;;            '((exec . "emacsclient -c -a emacs %u"))))
+;;          (xdg-desktop-entry
+;;           (file "text")
+;;           (name "Text editor")
+;;           (type 'application)
+;;           (config
+;;            '((exec . "emacsclient -c -a emacs %u")))
+;;           (actions
+;;            (list (xdg-desktop-action
+;;                   (action 'create)
+;;                   (name "Create an action")
+;;                   (config
+;;                    '((exec . "echo hi"))))))))))
+
+;; See
+;; <https://specifications.freedesktop.org/shared-mime-info-spec/shared-mime-info-spec-latest.html>
+;; <https://specifications.freedesktop.org/mime-apps-spec/mime-apps-spec-latest.html>
+
+(define (serialize-alist field-name val)
+  (define (serialize-mimelist-entry key val)
+    (let ((val (cond
+                ((list? val)
+                 (string-join (map maybe-object->string val) ";"))
+                ((or (string? val) (symbol? val))
+                 val)
+                (else (raise (formatted-message
+                              (G_ "\
+The value of an XDG MIME entry must be a list, string or symbol, was given ~a")
+                              val))))))
+      (format #f "~a=~a\n" key val)))
+
+  (define (merge-duplicates alist acc)
+    "Merge values that have the same key.
+
+@example
+(merge-duplicates '((key1 . value1)
+                      (key2 . value2)
+                      (key1 . value3)
+                      (key1 . value4)) '())
+
+@result{} ((key1 . (value4 value3 value1)) (key2 . value2))
+@end example"
+    (cond
+     ((null? alist) acc)
+     (else (let* ((head (first alist))
+                  (tail (cdr alist))
+                  (key (first head))
+                  (value (cdr head))
+                  (duplicate? (assoc key acc)))
+             (if duplicate?
+                 ;; XXX: This will change the order of things,
+                 ;; though, it shouldn't be a problem for XDG MIME.
+                 (merge-duplicates
+                  tail
+                  (alist-cons key
+                              (cons value (maybe-list (cdr duplicate?)))
+                              (alist-delete key acc)))
+                 (merge-duplicates tail (cons head acc)))))))
+
+  (string-append (if (equal? field-name 'default)
+                     "\n[Default Applications]\n"
+                     (format #f "\n[~a Associations]\n"
+                             (string-capitalize (symbol->string field-name))))
+                 (generic-serialize-alist string-append
+                                          serialize-mimelist-entry
+                                          (merge-duplicates val '()))))
+
+(define xdg-desktop-types (make-enumeration
+                           '(application
+                             link
+                             directory)))
+
+(define (xdg-desktop-type? type)
+  (unless (enum-set-member? type xdg-desktop-types)
+    (raise (formatted-message
+            (G_ "XDG desktop type must be of of ~a, was given: ~a")
+            (list->human-readable-list (enum-set->list xdg-desktop-types))
+            type))))
+
+;; TODO: Add proper docs for this
+;; XXX: 'define-configuration' require that fields have a default
+;; value.
+(define-record-type* <xdg-desktop-action>
+  xdg-desktop-action make-xdg-desktop-action
+  xdg-desktop-action?
+  (action xdg-desktop-action-action)    ; symbol
+  (name xdg-desktop-action-name)        ; string
+  (config xdg-desktop-action-config     ; alist
+                (default '())))
+
+(define-record-type* <xdg-desktop-entry>
+  xdg-desktop-entry make-xdg-desktop-entry
+  xdg-desktop-entry?
+  ;; ".desktop" will automatically be added
+  (file xdg-desktop-entry-file)         ; string
+  (name xdg-desktop-entry-name)         ; string
+  (type xdg-desktop-entry-type)         ; xdg-desktop-type
+  (config xdg-desktop-entry-config      ; alist
+                (default '()))
+  (actions xdg-desktop-entry-actions    ; list of <xdg-desktop-action>
+           (default '())))
+
+(define desktop-entries? (list-of xdg-desktop-entry?))
+(define (serialize-desktop-entries field-name val) "")
+
+(define (serialize-xdg-desktop-entry entry)
+  "Return a tuple of the file name for ENTRY and the serialized
+configuration."
+  (define (format-config key val)
+    (let ((val (cond
+                ((list? val)
+                 (string-join (map maybe-object->string val) ";"))
+                ((boolean? val)
+                 (if val "true" "false"))
+                (else val)))
+          (key (string-capitalize (maybe-object->string key))))
+      (list (if (string-suffix? key "?")
+                (string-drop-right key (- (string-length key) 1))
+                key)
+            "=" val "\n")))
+
+  (define (serialize-alist config)
+    (generic-serialize-alist identity format-config config))
+
+  (define (serialize-xdg-desktop-action action)
+    (match action
+      (($ <xdg-desktop-action> action name config)
+       `(,(format #f "[Desktop Action ~a]\n"
+                  (string-capitalize (maybe-object->string action)))
+         ,(format #f "Name=~a\n" name)
+         ,@(serialize-alist config)))))
+
+  (match entry
+    (($ <xdg-desktop-entry> file name type config actions)
+     (list (if (string-suffix? file ".desktop")
+               file
+               (string-append file ".desktop"))
+           `("[Desktop Entry]\n"
+             ,(format #f "Name=~a\n" name)
+             ,(format #f "Type=~a\n"
+                      (string-capitalize (symbol->string type)))
+             ,@(serialize-alist config)
+             ,@(append-map serialize-xdg-desktop-action actions))))))
+
+(define-configuration home-xdg-mime-applications-configuration
+  (added
+   (alist '())
+   "An association list of MIME types and desktop entries which indicate
+that the application should used to open the specified MIME type.  The
+value has to be string, symbol, or list of strings or symbols, this
+applies to the `@code{default}', and `@code{removed}' fields as well.")
+  (default
+    (alist '())
+    "An association list of MIME types and desktop entries which indicate
+that the application should be the default for opening the specified
+MIME type.")
+  (removed
+   (alist '())
+   "An association list of MIME types and desktop entries which indicate
+that the application cannot open the specified MIME type.")
+  (desktop-entries
+   (desktop-entries '())
+   "A list of XDG desktop entries to create.  See
+@code{xdg-desktop-entry}."))
+
+(define (home-xdg-mime-applications-files-service config)
+  (define (add-xdg-desktop-entry-file entry)
+    (let ((file (first entry))
+          (config (second entry)))
+      (list (format #f "local/share/applications/~a" file)
+          (apply mixed-text-file
+                 (format #f "xdg-desktop-~a-entry" file)
+                 config))))
+
+  (append
+   `(("config/mimeapps.list"
+      ,(mixed-text-file
+        "xdg-mime-appplications"
+        (serialize-configuration
+         config
+         home-xdg-mime-applications-configuration-fields))))
+   (map (compose add-xdg-desktop-entry-file serialize-xdg-desktop-entry)
+        (home-xdg-mime-applications-configuration-desktop-entries config))))
+
+(define (home-xdg-mime-applications-extension old-config extension-configs)
+  (define (extract-fields config)
+    ;; return '(added default removed desktop-entries)
+    (list (home-xdg-mime-applications-configuration-added config)
+          (home-xdg-mime-applications-configuration-default config)
+          (home-xdg-mime-applications-configuration-removed config)
+          (home-xdg-mime-applications-configuration-desktop-entries config)))
+
+  (define (append-configs elem acc)
+    (list (append (first elem) (first acc))
+          (append (second elem) (second acc))
+          (append (third elem) (third acc))
+          (append (fourth elem) (fourth acc))))
+
+  ;; TODO: Implement procedure to check for duplicates without
+  ;; sacrificing performance.
+  ;;
+  ;; Combine all the alists from 'added', 'default' and 'removed'
+  ;; into one big alist.
+  (let ((folded-configs (fold append-configs
+                              (extract-fields old-config)
+                              (map extract-fields extension-configs))))
+    (home-xdg-mime-applications-configuration
+     (added (first folded-configs))
+     (default (second folded-configs))
+     (removed (third folded-configs))
+     (desktop-entries (fourth folded-configs)))))
+
+(define home-xdg-mime-applications-service-type
+  (service-type (name 'home-xdg-mime-applications)
+                (extensions
+                 (list (service-extension
+                        home-files-service-type
+                        home-xdg-mime-applications-files-service)))
+                (compose identity)
+                (extend home-xdg-mime-applications-extension)
+                (default-value (home-xdg-mime-applications-configuration))
+                (description
+                 "Configure XDG MIME applications, and XDG desktop entries.")))
diff --git a/gnu/local.mk b/gnu/local.mk
index dc0e732114..8c44c143af 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -77,6 +77,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/home-services/fontutils.scm               \
   %D%/home-services/configuration.scm           \
   %D%/home-services/shells.scm                  \
+  %D%/home-services/xdg.scm                     \
   %D%/image.scm					\
   %D%/packages.scm				\
   %D%/packages/abduco.scm			\
-- 
2.33.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 853 bytes --]

[bug#50208] [PATCH 5/5] home: Add home-environment.

[Andrew Tropin]

[-- Attachment #1: Type: text/plain, Size: 5078 bytes --]

* gnu/home.scm
(home-environment, home-environment?, this-home-environment)
(home-environment-derivation, home-environment-user-services)
(home-environment-essential-services, home-environment-services)
(home-environment-location, home-environment-with-provenance): New variables.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add home.scm.
---
 gnu/home.scm | 97 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 gnu/local.mk |  1 +
 2 files changed, 98 insertions(+)
 create mode 100644 gnu/home.scm

diff --git a/gnu/home.scm b/gnu/home.scm
new file mode 100644
index 0000000000..220cc49846
--- /dev/null
+++ b/gnu/home.scm
@@ -0,0 +1,97 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;;
+;;; 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)
+  #:use-module (gnu home-services)
+  #:use-module (gnu home-services symlink-manager)
+  #:use-module (gnu home-services shells)
+  #:use-module (gnu home-services xdg)
+  #:use-module (gnu home-services fontutils)
+  #:use-module (gnu services)
+  #:use-module (guix records)
+  #:use-module (guix diagnostics)
+
+  #:export (home-environment
+            home-environment?
+            this-home-environment
+
+            home-environment-derivation
+            home-environment-user-services
+            home-environment-essential-services
+            home-environment-services
+            home-environment-location
+
+            home-environment-with-provenance))
+
+(define-record-type* <home-environment> home-environment
+  make-home-environment
+  home-environment?
+  this-home-environment
+
+  (packages home-environment-packages             ; list of (PACKAGE OUTPUT...)
+            (default '()))
+
+  (essential-services home-environment-essential-services ; list of services
+                      (thunked)
+                      (default (home-environment-default-essential-services
+                                this-home-environment)))
+  (services home-environment-user-services
+            (default '()))
+
+  (location home-environment-location             ; <location>
+            (default (and=> (current-source-location)
+                            source-properties->location))
+            (innate)))
+
+(define (home-environment-default-essential-services he)
+  "Return the list of essential services for home environment."
+  (list
+   (service home-run-on-first-login-service-type)
+   (service home-activation-service-type)
+   (service home-environment-variables-service-type)
+
+   (service home-symlink-manager-service-type)
+
+   (service home-fontconfig-service-type)
+   (service home-xdg-base-directories-service-type)
+   (service home-shell-profile-service-type)
+
+   (service home-service-type)
+   (service home-profile-service-type (home-environment-packages he))))
+
+(define* (home-environment-services he)
+  "Return all the services of home environment."
+  (instantiate-missing-services
+   (append (home-environment-user-services he)
+           (home-environment-essential-services he))))
+
+(define* (home-environment-derivation he)
+  "Return a derivation that builds OS."
+  (let* ((services         (home-environment-services he))
+         (home (fold-services services
+                              #:target-type home-service-type)))
+    (service-value home)))
+
+(define* (home-environment-with-provenance he config-file)
+  "Return a variant of HE that stores its own provenance information,
+including CONFIG-FILE, if available.  This is achieved by adding an instance
+of HOME-PROVENANCE-SERVICE-TYPE to its services."
+  (home-environment
+    (inherit he)
+    (services (cons (service home-provenance-service-type config-file)
+                    (home-environment-user-services he)))))
diff --git a/gnu/local.mk b/gnu/local.mk
index 8c44c143af..bbaee51140 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -72,6 +72,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/bootloader/u-boot.scm                     \
   %D%/bootloader/depthcharge.scm                \
   %D%/ci.scm					\
+  %D%/home.scm                                  \
   %D%/home-services.scm                         \
   %D%/home-services/symlink-manager.scm         \
   %D%/home-services/fontutils.scm               \
-- 
2.33.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 853 bytes --]

[bug#50208] [PATCH 5/5] home: Add home-environment.

[Xinglu Chen]

[-- Attachment #1: Type: text/plain, Size: 2564 bytes --]

On Fri, Aug 27 2021, Andrew Tropin wrote:

> * gnu/home.scm
> (home-environment, home-environment?, this-home-environment)
> (home-environment-derivation, home-environment-user-services)
> (home-environment-essential-services, home-environment-services)
> (home-environment-location, home-environment-with-provenance): New variables.
> * gnu/local.mk (GNU_SYSTEM_MODULES): Add home.scm.
> ---
>  gnu/home.scm | 97 ++++++++++++++++++++++++++++++++++++++++++++++++++++
>  gnu/local.mk |  1 +
>  2 files changed, 98 insertions(+)
>  create mode 100644 gnu/home.scm
>
> diff --git a/gnu/home.scm b/gnu/home.scm
> new file mode 100644
> index 0000000000..220cc49846
> --- /dev/null
> +++ b/gnu/home.scm
> @@ -0,0 +1,97 @@
> +;;; GNU Guix --- Functional package management for GNU
> +;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
> +;;;
> +;;; 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)
> +  #:use-module (gnu home-services)
> +  #:use-module (gnu home-services symlink-manager)
> +  #:use-module (gnu home-services shells)
> +  #:use-module (gnu home-services xdg)
> +  #:use-module (gnu home-services fontutils)
> +  #:use-module (gnu services)
> +  #:use-module (guix records)
> +  #:use-module (guix diagnostics)
> +
> +  #:export (home-environment
> +            home-environment?
> +            this-home-environment
> +
> +            home-environment-derivation
> +            home-environment-user-services
> +            home-environment-essential-services
> +            home-environment-services
> +            home-environment-location
> +
> +            home-environment-with-provenance))
> +

It should probably have a ‘Commentary’ section.  Maybe something like

  This module provides a <home-environment> record for managing per-user
  packages and 'dotfiles'.

?

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 861 bytes --]

[bug#50208] [PATCH 5/5] home: Add home-environment.

[Andrew Tropin]

[-- Attachment #1: Type: text/plain, Size: 2727 bytes --]

On 2021-08-28 12:44, Xinglu Chen wrote:

> On Fri, Aug 27 2021, Andrew Tropin wrote:
>
>> * gnu/home.scm
>> (home-environment, home-environment?, this-home-environment)
>> (home-environment-derivation, home-environment-user-services)
>> (home-environment-essential-services, home-environment-services)
>> (home-environment-location, home-environment-with-provenance): New variables.
>> * gnu/local.mk (GNU_SYSTEM_MODULES): Add home.scm.
>> ---
>>  gnu/home.scm | 97 ++++++++++++++++++++++++++++++++++++++++++++++++++++
>>  gnu/local.mk |  1 +
>>  2 files changed, 98 insertions(+)
>>  create mode 100644 gnu/home.scm
>>
>> diff --git a/gnu/home.scm b/gnu/home.scm
>> new file mode 100644
>> index 0000000000..220cc49846
>> --- /dev/null
>> +++ b/gnu/home.scm
>> @@ -0,0 +1,97 @@
>> +;;; GNU Guix --- Functional package management for GNU
>> +;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
>> +;;;
>> +;;; 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)
>> +  #:use-module (gnu home-services)
>> +  #:use-module (gnu home-services symlink-manager)
>> +  #:use-module (gnu home-services shells)
>> +  #:use-module (gnu home-services xdg)
>> +  #:use-module (gnu home-services fontutils)
>> +  #:use-module (gnu services)
>> +  #:use-module (guix records)
>> +  #:use-module (guix diagnostics)
>> +
>> +  #:export (home-environment
>> +            home-environment?
>> +            this-home-environment
>> +
>> +            home-environment-derivation
>> +            home-environment-user-services
>> +            home-environment-essential-services
>> +            home-environment-services
>> +            home-environment-location
>> +
>> +            home-environment-with-provenance))
>> +
>
> It should probably have a ‘Commentary’ section.  Maybe something like
>
>   This module provides a <home-environment> record for managing per-user
>   packages and 'dotfiles'.
>
> ?

Thank you for the idea, added a doc comment.

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#50208] [PATCH 0/5] Add home-environment and related services

[Andrew Tropin]

[-- Attachment #1: Type: text/plain, Size: 1811 bytes --]

On 2021-08-27 09:49, Andrew Tropin wrote:

> On 2021-08-26 13:58, Oleg Pykhalov wrote:
>
>> I applied your patch, replaces tabs with spaces, modified commit message
>> according to GNU standards, added the file to gnu/local.mk for
>> compilation (I forgot to do it for previous patch series, apologies).
>>
>>
>> I would like to squash the patch for home-services.scm with a previous
>> series (hope force push will work), but I should ask you could I do it?
>> Otherwise I could just push two patches to wip-guix-home.
>>
>> Updated patches are attached below.
>
> On top of the patches above I made a new patch series, which introduces
> home-environment and a set of default services, which are expected to be
> present in most Guix Home configurations.
>
> Andrew Tropin (5):
>   home-services: Add fontutils.
>   home-services: Add helper functions for service configurations.
>   home-services: Add shells.
>   home-services: Add xdg.
>   home: Add home-environment.
>
>  gnu/home-services/configuration.scm |  63 +++
>  gnu/home-services/fontutils.scm     |  65 +++
>  gnu/home-services/shells.scm        | 637 ++++++++++++++++++++++++++++
>  gnu/home-services/xdg.scm           | 475 +++++++++++++++++++++
>  gnu/home.scm                        |  97 +++++
>  gnu/local.mk                        |   5 +
>  6 files changed, 1342 insertions(+)
>  create mode 100644 gnu/home-services/configuration.scm
>  create mode 100644 gnu/home-services/fontutils.scm
>  create mode 100644 gnu/home-services/shells.scm
>  create mode 100644 gnu/home-services/xdg.scm
>  create mode 100644 gnu/home.scm

Is it ok to keep discussion and review of the patch series in this
thread or better create a new ticket for that?

I posted it here, because it relies on symlink-manager, but not sure if
it's handy for reviewers.

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

bug#50208: [PATCH 0/5] Add home-environment and related services

[Oleg Pykhalov]

[-- Attachment #1: Type: text/plain, Size: 1630 bytes --]

Andrew Tropin <andrew@trop.in> writes:

[…]

>> On top of the patches above I made a new patch series, which introduces
>> home-environment and a set of default services, which are expected to be
>> present in most Guix Home configurations.

I added a copyright in gnu/home-services/configuration.scm and a
copyright line in gnu/local.mk files.

From gnu/home-services/shells.scm removed 3 comment lines at the bottom,
because I don't see this practice in other Guix documentation generation
functions:
--8<---------------cut here---------------start------------->8---
;; (display (generate-home-shell-profile-documentation))
;; (display (generate-home-bash-documentation))
;; (display (generate-home-zsh-documentation))
--8<---------------cut here---------------end--------------->8---

In gnu/home.scm and gnu/home-services/xdg.scm alligned
define-record-type* with Emacs's ‘M-x aggressive-indent-mode’ and
‘M-x align-regexp’ <SPC ;>.

Unfortunately force push is disallowed, removed origin/wip-guix-home and
pushed again with squashed local.mk and slightly modified commit
messages (missing dots at the commit messages).

[…]

> Is it ok to keep discussion and review of the patch series in this
> thread or better create a new ticket for that?
>
> I posted it here, because it relies on symlink-manager, but not sure if
> it's handy for reviewers.

I think it's OK to keep discussion here, because every patch is a part
of guix-home.  Not a strong opinion on that.

I'll close the issue for now, it should reopen in case you send an email
to 50208@debbugs.gnu.org

Oleg.

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 861 bytes --]

[bug#50208] [PATCH 0/4] Fixes and improvements for home-services

[Andrew Tropin]

[-- Attachment #1.1: Type: text/plain, Size: 986 bytes --]


There are a few follow up patches for the current wip-guix-home branch:
- Add utils ns with helpers for converting cases, which was missing.
- Fix issue with creating first home-environment generation.
- Add support to activation script for multiline values for environment
variables.
- Add a doc comment.

The patches are attached to this messages.

Andrew Tropin (4):
  home-services: Add utils module.
  home-services: symlink-manager: Properly handle 1st generation case
  home-services: activation: Add support for multiline env vars
  gnu: home: Add doc comment about the module

 gnu/home-services.scm                 |  4 +-
 gnu/home-services/shells.scm          |  1 +
 gnu/home-services/symlink-manager.scm |  2 +-
 gnu/home-services/utils.scm           | 77 +++++++++++++++++++++++++++
 gnu/home.scm                          |  8 +++
 5 files changed, 89 insertions(+), 3 deletions(-)
 create mode 100644 gnu/home-services/utils.scm

-- 
2.33.0


[-- Attachment #1.2: 0001-home-services-Add-utils-module.patch --]
[-- Type: text/x-patch, Size: 4452 bytes --]

From 93ae498296b37e5b21b6a824d090b0898b870a39 Mon Sep 17 00:00:00 2001
From: Andrew Tropin <andrew@trop.in>
Date: Mon, 30 Aug 2021 12:17:11 +0300
Subject: [PATCH 1/4] home-services: Add utils module.

* gnu/home-services/utils.scm (maybe-object->string object->snake-case-string)
(object->snake-case-string): New variables.
---
 gnu/home-services/shells.scm |  1 +
 gnu/home-services/utils.scm  | 77 ++++++++++++++++++++++++++++++++++++
 2 files changed, 78 insertions(+)
 create mode 100644 gnu/home-services/utils.scm

diff --git a/gnu/home-services/shells.scm b/gnu/home-services/shells.scm
index b8065d28d2..ecb02098f7 100644
--- a/gnu/home-services/shells.scm
+++ b/gnu/home-services/shells.scm
@@ -20,6 +20,7 @@
 (define-module (gnu home-services shells)
   #:use-module (gnu services configuration)
   #:use-module (gnu home-services configuration)
+  #:use-module (gnu home-services utils)
   #:use-module (gnu home-services)
   #:use-module (gnu packages shells)
   #:use-module (gnu packages bash)
diff --git a/gnu/home-services/utils.scm b/gnu/home-services/utils.scm
new file mode 100644
index 0000000000..3e490a0515
--- /dev/null
+++ b/gnu/home-services/utils.scm
@@ -0,0 +1,77 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;;
+;;; 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 utils)
+  #:use-module (ice-9 string-fun)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+
+  #:export (maybe-object->string
+            object->snake-case-string
+            object->camel-case-string))
+
+(define (maybe-object->string object)
+  "Like @code{object->string} but don't do anyting if OBJECT already is
+a string."
+  (if (string? object)
+      object
+      (object->string object)))
+
+;; Snake case: <https://en.wikipedia.org/wiki/Snake_case>
+(define* (object->snake-case-string object #:optional (style 'lower))
+  "Convert the object OBJECT to the equivalent string in ``snake
+case''.  STYLE can be three `@code{lower}', `@code{upper}', or
+`@code{capitalize}', defaults to `@code{lower}'.
+
+@example
+(object->snake-case-string 'variable-name 'upper)
+@result{} \"VARIABLE_NAME\" @end example"
+  (if (not (member style '(lower upper capitalize)))
+      (error 'invalid-style (format #f "~a is not a valid style" style))
+      (let ((stringified (maybe-object->string object)))
+        (string-replace-substring
+         (cond
+          ((equal? style 'lower) stringified)
+          ((equal? style 'upper) (string-upcase stringified))
+          (else (string-capitalize stringified)))
+         "-" "_"))))
+
+(define* (object->camel-case-string object #:optional (style 'lower))
+  "Convert the object OBJECT to the equivalent string in ``camel case''.
+STYLE can be three `@code{lower}', `@code{upper}', defaults to
+`@code{lower}'.
+
+@example
+(object->camel-case-string 'variable-name 'upper)
+@result{} \"VariableName\"
+@end example"
+  (if (not (member style '(lower upper)))
+      (error 'invalid-style (format #f "~a is not a valid style" style))
+      (let ((stringified (maybe-object->string object)))
+        (cond
+         ((eq? style 'upper)
+          (string-concatenate
+           (map string-capitalize
+                (string-split stringified (cut eqv? <> #\-)))))
+         ((eq? style 'lower)
+          (let ((splitted-string (string-split stringified (cut eqv? <> #\-))))
+            (string-concatenate
+             (cons (first splitted-string)
+                   (map string-capitalize
+                        (cdr splitted-string))))))))))
-- 
2.33.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.3: 0002-home-services-symlink-manager-Properly-handle-1st-ge.patch --]
[-- Type: text/x-patch, Size: 1071 bytes --]

From eebdfd72d2e20b18154f66fc0f84c723340e3b5f Mon Sep 17 00:00:00 2001
From: Andrew Tropin <andrew@trop.in>
Date: Mon, 30 Aug 2021 12:23:48 +0300
Subject: [PATCH 2/4] home-services: symlink-manager: Properly handle 1st
 generation case

---
 gnu/home-services/symlink-manager.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gnu/home-services/symlink-manager.scm b/gnu/home-services/symlink-manager.scm
index dc409d2ae2..11f5d503d4 100644
--- a/gnu/home-services/symlink-manager.scm
+++ b/gnu/home-services/symlink-manager.scm
@@ -102,7 +102,7 @@ appear only after all nested items already listed."
                                          (number->string (current-time))
                                          "-guix-home-legacy-configs-backup"))
 
-              (old-tree (if (file-exists? old-home)
+              (old-tree (if old-home
                           ((simplify-file-tree "")
                            (file-system-tree
                             (string-append old-home "/files/.")))
-- 
2.33.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.4: 0003-home-services-activation-Add-support-for-multiline-e.patch --]
[-- Type: text/x-patch, Size: 1452 bytes --]

From 25f61084e11fccc50dc1fbec3b28e7dea091e625 Mon Sep 17 00:00:00 2001
From: Andrew Tropin <andrew@trop.in>
Date: Mon, 30 Aug 2021 12:26:19 +0300
Subject: [PATCH 3/4] home-services: activation: Add support for multiline env
 vars

---
 gnu/home-services.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/home-services.scm b/gnu/home-services.scm
index 16b9736d64..2a773496f0 100644
--- a/gnu/home-services.scm
+++ b/gnu/home-services.scm
@@ -324,7 +324,7 @@ extended with one gexp.")))
                               #f))))
        (if (file-exists? (he-init-file new-home))
            (let* ((port   ((@ (ice-9 popen) open-input-pipe)
-                           (format #f "source ~a && env"
+                           (format #f "source ~a && env -0"
                                    (he-init-file new-home))))
                   (result ((@ (ice-9 rdelim) read-delimited) "" port))
                   (vars (map (lambda (x)
@@ -333,7 +333,7 @@ extended with one gexp.")))
                                        (string-drop x (1+ si)))))
                              ((@ (srfi srfi-1) remove)
                               string-null?
-                              (string-split result #\newline)))))
+                              (string-split result #\nul)))))
              (close-port port)
              (map (lambda (x) (setenv (car x) (cdr x))) vars)
 
-- 
2.33.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.5: 0004-gnu-home-Add-doc-comment-about-the-module.patch --]
[-- Type: text/x-patch, Size: 855 bytes --]

From ec05edf310609dd1424ce7bfdcaaf6758a77fe29 Mon Sep 17 00:00:00 2001
From: Andrew Tropin <andrew@trop.in>
Date: Mon, 30 Aug 2021 12:07:48 +0300
Subject: [PATCH 4/4] gnu: home: Add doc comment about the module

---
 gnu/home.scm | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/gnu/home.scm b/gnu/home.scm
index a53d27163d..f4c9359e25 100644
--- a/gnu/home.scm
+++ b/gnu/home.scm
@@ -38,6 +38,14 @@
 
             home-environment-with-provenance))
 
+;;; Comment:
+;;;
+;;; This module provides a <home-environment> record for managing
+;;; per-user packages and configuration files in the similar way as
+;;; <operating-system> do for system packages and configuration files.
+;;;
+;;; Code:
+
 (define-record-type* <home-environment> home-environment
   make-home-environment
   home-environment?
-- 
2.33.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#50208] [PATCH v2 0/5] Fixes and improvements for home-services

[Andrew Tropin]

[-- Attachment #1.1: Type: text/plain, Size: 835 bytes --]


Changes since v1:
Added missing import to xdg via a separate commit.
Added trailing dots to commit messages.

Andrew Tropin (5):
  home-services: Add utils module.
  home-services: symlink-manager: Properly handle 1st generation case.
  home-services: activation: Add support for multiline env vars.
  gnu: home: Add doc comment about the module.
  home-services: xdg: Add missing import.

 gnu/home-services.scm                 |  4 +-
 gnu/home-services/shells.scm          |  1 +
 gnu/home-services/symlink-manager.scm |  2 +-
 gnu/home-services/utils.scm           | 77 +++++++++++++++++++++++++++
 gnu/home-services/xdg.scm             |  1 +
 gnu/home.scm                          |  8 +++
 6 files changed, 90 insertions(+), 3 deletions(-)
 create mode 100644 gnu/home-services/utils.scm

-- 
2.33.0



[-- Attachment #1.2: v2-0001-home-services-Add-utils-module.patch --]
[-- Type: text/x-patch, Size: 4455 bytes --]

From 93ae498296b37e5b21b6a824d090b0898b870a39 Mon Sep 17 00:00:00 2001
From: Andrew Tropin <andrew@trop.in>
Date: Mon, 30 Aug 2021 12:17:11 +0300
Subject: [PATCH v2 1/5] home-services: Add utils module.

* gnu/home-services/utils.scm (maybe-object->string object->snake-case-string)
(object->snake-case-string): New variables.
---
 gnu/home-services/shells.scm |  1 +
 gnu/home-services/utils.scm  | 77 ++++++++++++++++++++++++++++++++++++
 2 files changed, 78 insertions(+)
 create mode 100644 gnu/home-services/utils.scm

diff --git a/gnu/home-services/shells.scm b/gnu/home-services/shells.scm
index b8065d28d2..ecb02098f7 100644
--- a/gnu/home-services/shells.scm
+++ b/gnu/home-services/shells.scm
@@ -20,6 +20,7 @@
 (define-module (gnu home-services shells)
   #:use-module (gnu services configuration)
   #:use-module (gnu home-services configuration)
+  #:use-module (gnu home-services utils)
   #:use-module (gnu home-services)
   #:use-module (gnu packages shells)
   #:use-module (gnu packages bash)
diff --git a/gnu/home-services/utils.scm b/gnu/home-services/utils.scm
new file mode 100644
index 0000000000..3e490a0515
--- /dev/null
+++ b/gnu/home-services/utils.scm
@@ -0,0 +1,77 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;;
+;;; 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 utils)
+  #:use-module (ice-9 string-fun)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+
+  #:export (maybe-object->string
+            object->snake-case-string
+            object->camel-case-string))
+
+(define (maybe-object->string object)
+  "Like @code{object->string} but don't do anyting if OBJECT already is
+a string."
+  (if (string? object)
+      object
+      (object->string object)))
+
+;; Snake case: <https://en.wikipedia.org/wiki/Snake_case>
+(define* (object->snake-case-string object #:optional (style 'lower))
+  "Convert the object OBJECT to the equivalent string in ``snake
+case''.  STYLE can be three `@code{lower}', `@code{upper}', or
+`@code{capitalize}', defaults to `@code{lower}'.
+
+@example
+(object->snake-case-string 'variable-name 'upper)
+@result{} \"VARIABLE_NAME\" @end example"
+  (if (not (member style '(lower upper capitalize)))
+      (error 'invalid-style (format #f "~a is not a valid style" style))
+      (let ((stringified (maybe-object->string object)))
+        (string-replace-substring
+         (cond
+          ((equal? style 'lower) stringified)
+          ((equal? style 'upper) (string-upcase stringified))
+          (else (string-capitalize stringified)))
+         "-" "_"))))
+
+(define* (object->camel-case-string object #:optional (style 'lower))
+  "Convert the object OBJECT to the equivalent string in ``camel case''.
+STYLE can be three `@code{lower}', `@code{upper}', defaults to
+`@code{lower}'.
+
+@example
+(object->camel-case-string 'variable-name 'upper)
+@result{} \"VariableName\"
+@end example"
+  (if (not (member style '(lower upper)))
+      (error 'invalid-style (format #f "~a is not a valid style" style))
+      (let ((stringified (maybe-object->string object)))
+        (cond
+         ((eq? style 'upper)
+          (string-concatenate
+           (map string-capitalize
+                (string-split stringified (cut eqv? <> #\-)))))
+         ((eq? style 'lower)
+          (let ((splitted-string (string-split stringified (cut eqv? <> #\-))))
+            (string-concatenate
+             (cons (first splitted-string)
+                   (map string-capitalize
+                        (cdr splitted-string))))))))))
-- 
2.33.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.3: v2-0002-home-services-symlink-manager-Properly-handle-1st.patch --]
[-- Type: text/x-patch, Size: 1075 bytes --]

From 710a4983790ecdae7aa53acb5361669b6061e551 Mon Sep 17 00:00:00 2001
From: Andrew Tropin <andrew@trop.in>
Date: Mon, 30 Aug 2021 12:23:48 +0300
Subject: [PATCH v2 2/5] home-services: symlink-manager: Properly handle 1st
 generation case.

---
 gnu/home-services/symlink-manager.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gnu/home-services/symlink-manager.scm b/gnu/home-services/symlink-manager.scm
index dc409d2ae2..11f5d503d4 100644
--- a/gnu/home-services/symlink-manager.scm
+++ b/gnu/home-services/symlink-manager.scm
@@ -102,7 +102,7 @@ appear only after all nested items already listed."
                                          (number->string (current-time))
                                          "-guix-home-legacy-configs-backup"))
 
-              (old-tree (if (file-exists? old-home)
+              (old-tree (if old-home
                           ((simplify-file-tree "")
                            (file-system-tree
                             (string-append old-home "/files/.")))
-- 
2.33.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.4: v2-0003-home-services-activation-Add-support-for-multilin.patch --]
[-- Type: text/x-patch, Size: 1456 bytes --]

From 78b9527c368549af63d8fb987d7f9ce3e472d6ae Mon Sep 17 00:00:00 2001
From: Andrew Tropin <andrew@trop.in>
Date: Mon, 30 Aug 2021 12:26:19 +0300
Subject: [PATCH v2 3/5] home-services: activation: Add support for multiline
 env vars.

---
 gnu/home-services.scm | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gnu/home-services.scm b/gnu/home-services.scm
index 16b9736d64..2a773496f0 100644
--- a/gnu/home-services.scm
+++ b/gnu/home-services.scm
@@ -324,7 +324,7 @@ extended with one gexp.")))
                               #f))))
        (if (file-exists? (he-init-file new-home))
            (let* ((port   ((@ (ice-9 popen) open-input-pipe)
-                           (format #f "source ~a && env"
+                           (format #f "source ~a && env -0"
                                    (he-init-file new-home))))
                   (result ((@ (ice-9 rdelim) read-delimited) "" port))
                   (vars (map (lambda (x)
@@ -333,7 +333,7 @@ extended with one gexp.")))
                                        (string-drop x (1+ si)))))
                              ((@ (srfi srfi-1) remove)
                               string-null?
-                              (string-split result #\newline)))))
+                              (string-split result #\nul)))))
              (close-port port)
              (map (lambda (x) (setenv (car x) (cdr x))) vars)
 
-- 
2.33.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.5: v2-0004-gnu-home-Add-doc-comment-about-the-module.patch --]
[-- Type: text/x-patch, Size: 859 bytes --]

From e2257d5b134a52b67a2e4b3b1e95b73eef975401 Mon Sep 17 00:00:00 2001
From: Andrew Tropin <andrew@trop.in>
Date: Mon, 30 Aug 2021 12:07:48 +0300
Subject: [PATCH v2 4/5] gnu: home: Add doc comment about the module.

---
 gnu/home.scm | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/gnu/home.scm b/gnu/home.scm
index a53d27163d..f4c9359e25 100644
--- a/gnu/home.scm
+++ b/gnu/home.scm
@@ -38,6 +38,14 @@
 
             home-environment-with-provenance))
 
+;;; Comment:
+;;;
+;;; This module provides a <home-environment> record for managing
+;;; per-user packages and configuration files in the similar way as
+;;; <operating-system> do for system packages and configuration files.
+;;;
+;;; Code:
+
 (define-record-type* <home-environment> home-environment
   make-home-environment
   home-environment?
-- 
2.33.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #1.6: v2-0005-home-services-xdg-Add-missing-import.patch --]
[-- Type: text/x-patch, Size: 686 bytes --]

From 2c7a295468aecd4f40e98ac0651800f561d89a71 Mon Sep 17 00:00:00 2001
From: Andrew Tropin <andrew@trop.in>
Date: Mon, 30 Aug 2021 13:22:16 +0300
Subject: [PATCH v2 5/5] home-services: xdg: Add missing import.

---
 gnu/home-services/xdg.scm | 1 +
 1 file changed, 1 insertion(+)

diff --git a/gnu/home-services/xdg.scm b/gnu/home-services/xdg.scm
index 6e4a2542a3..535c8667a1 100644
--- a/gnu/home-services/xdg.scm
+++ b/gnu/home-services/xdg.scm
@@ -26,6 +26,7 @@
   #:use-module (guix gexp)
   #:use-module (guix records)
   #:use-module (guix i18n)
+  #:use-module (guix diagnostics)
 
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
-- 
2.33.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

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

[Oleg Pykhalov]

[-- Attachment #1: Type: text/plain, Size: 977 bytes --]

Andrew Tropin <andrew@trop.in> writes:

> Changes since v1:
> Added missing import to xdg via a separate commit.
> Added trailing dots to commit messages.
>
> Andrew Tropin (5):
>   home-services: Add utils module.
>   home-services: symlink-manager: Properly handle 1st generation case.
>   home-services: activation: Add support for multiline env vars.
>   gnu: home: Add doc comment about the module.
>   home-services: xdg: Add missing import.
>
>  gnu/home-services.scm                 |  4 +-
>  gnu/home-services/shells.scm          |  1 +
>  gnu/home-services/symlink-manager.scm |  2 +-
>  gnu/home-services/utils.scm           | 77 +++++++++++++++++++++++++++
>  gnu/home-services/xdg.scm             |  1 +
>  gnu/home.scm                          |  8 +++
>  6 files changed, 90 insertions(+), 3 deletions(-)
>  create mode 100644 gnu/home-services/utils.scm
>
> -- 
> 2.33.0

[…]

Tabified local.mk, pushed to wip-guix-home.

Oleg.

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 861 bytes --]

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

[Andrew Tropin]

[-- Attachment #1: Type: text/plain, Size: 1206 bytes --]

On 2021-08-31 02:19, Oleg Pykhalov wrote:

> Andrew Tropin <andrew@trop.in> writes:
>
>> Changes since v1:
>> Added missing import to xdg via a separate commit.
>> Added trailing dots to commit messages.
>>
>> Andrew Tropin (5):
>>   home-services: Add utils module.
>>   home-services: symlink-manager: Properly handle 1st generation case.
>>   home-services: activation: Add support for multiline env vars.
>>   gnu: home: Add doc comment about the module.
>>   home-services: xdg: Add missing import.
>>
>>  gnu/home-services.scm                 |  4 +-
>>  gnu/home-services/shells.scm          |  1 +
>>  gnu/home-services/symlink-manager.scm |  2 +-
>>  gnu/home-services/utils.scm           | 77 +++++++++++++++++++++++++++
>>  gnu/home-services/xdg.scm             |  1 +
>>  gnu/home.scm                          |  8 +++
>>  6 files changed, 90 insertions(+), 3 deletions(-)
>>  create mode 100644 gnu/home-services/utils.scm
>>
>> -- 
>> 2.33.0
>
> […]
>
> Tabified local.mk, pushed to wip-guix-home.
>
> Oleg.

It seems we are finished with basic home-services, refactoring and
preparing CLI now, will send it in a separate thread.

Thank you very much!)

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

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

[Jelle Licht]

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.

> +;;; 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.

> +       (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
> +	 (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?
tmp-path, to me at least, evokes a place where temporary files are
stored, contrasted to a temporary home for important files.

> +
> +	      (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.

> +
> +	      (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.

> +			 (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.

> -- 
> 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?

Thanks again for working on this!
 - Jelle

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

[Andrew Tropin]

[-- Attachment #1.1: Type: text/plain, Size: 12941 bytes --]

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.


[-- Attachment #1.2: v2-0001-home-services-Add-symlink-manager.patch --]
[-- Type: text/x-patch, Size: 11761 bytes --]

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


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]