* [bug#54180] [PATCH 02/12] home: symlink-manager: Move helper procedures as top-level defines.
2022-02-27 13:53 ` [bug#54180] [PATCH 01/12] home: symlink-manager: Clarify module imports Ludovic Courtès
@ 2022-02-27 13:53 ` Ludovic Courtès
2022-02-27 15:58 ` Maxime Devos
2022-02-27 13:53 ` [bug#54180] [PATCH 03/12] home: symlink-manager: Use 'for-each' when used for effects Ludovic Courtès
` (9 subsequent siblings)
10 siblings, 1 reply; 28+ messages in thread
From: Ludovic Courtès @ 2022-02-27 13:53 UTC (permalink / raw)
To: 54180; +Cc: Ludovic Courtès
* gnu/home/services/symlink-manager.scm (update-symlinks-script): Remove
'config-home', which is unused. Move 'home-path', 'backup-dir',
'get-target-path', 'get-backup-path', 'directory?', 'empty-directory?',
'symlink-to-store?', and 'backup-file' to the top level. Move
'create-symlinks' and 'cleanup-symlinks' to the top level as well, and
add parameters. Adjust callers.
---
gnu/home/services/symlink-manager.scm | 240 +++++++++++++-------------
1 file changed, 116 insertions(+), 124 deletions(-)
diff --git a/gnu/home/services/symlink-manager.scm b/gnu/home/services/symlink-manager.scm
index c60cdcffb7..25470209d1 100644
--- a/gnu/home/services/symlink-manager.scm
+++ b/gnu/home/services/symlink-manager.scm
@@ -88,12 +88,121 @@ (define ((file-tree-traverse preordering) node)
(list (cons 'dir path))
(append-map (file-tree-traverse preordering) rest))))))
+ (define home-path
+ (getenv "HOME"))
+
+ (define backup-dir
+ (string-append home-path "/" (number->string (current-time))
+ "-guix-home-legacy-configs-backup"))
+
+ (define (get-target-path path)
+ (string-append home-path "/." path))
+
+ (define (get-backup-path path)
+ (string-append backup-dir "/." path))
+
+ (define (directory? path)
+ (equal? (stat:type (stat path)) 'directory))
+
+ (define (empty-directory? dir)
+ (equal? (scandir dir) '("." "..")))
+
+ (define (symlink-to-store? path)
+ (and (equal? (stat:type (lstat path)) 'symlink)
+ (store-file-name? (readlink path))))
+
+ (define (backup-file path)
+ (mkdir-p backup-dir)
+ (format #t (G_ "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 (G_ " done\n")))
+
+ (define (cleanup-symlinks old-tree)
+ ;; Delete from directory OLD-TREE symlinks that correspond to a
+ ;; previous generation.
+ (let ((to-delete ((file-tree-traverse #f) old-tree)))
+ (display
+ (G_
+ "Cleaning up symlinks from previous home-environment.\n\n"))
+ (map
+ (match-lambda
+ (('dir . ".")
+ (display (G_ "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 (G_ "Removing ~a...")
+ (get-target-path path))
+ (rmdir (get-target-path path))
+ (display (G_ " done\n")))
+ (format
+ #t
+ (G_ "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 (G_ "Removing ~a...") (get-target-path path))
+ (delete-file (get-target-path path))
+ (display (G_ " done\n")))
+ (format
+ #t
+ (G_ "Skipping ~a (not a symlink to store)... done\n")
+ (get-target-path path))))))
+ to-delete)))
+
+ (define (create-symlinks new-tree new-files-path)
+ ;; Create in directory NEW-TREE symlinks to the files under
+ ;; NEW-FILES-PATH, creating backups as needed.
+ (define (get-source-path path)
+ (readlink (string-append new-files-path "/" path)))
+
+ (let ((to-create ((file-tree-traverse #t) new-tree)))
+ (map
+ (match-lambda
+ (('dir . ".")
+ (display
+ (G_ "New symlinks to home-environment will be created soon.\n"))
+ (format
+ #t (G_ "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 (G_ "Skipping ~a (directory already exists)... done\n")
+ target-path)
+ (begin
+ (format #t (G_ "Creating ~a...") target-path)
+ (mkdir target-path)
+ (display (G_ " done\n"))))))
+
+ (('file . path)
+ (when (file-exists? (get-target-path path))
+ (backup-file path))
+ (format #t (G_ "Symlinking ~a -> ~a...")
+ (get-target-path path) (get-source-path path))
+ (symlink (get-source-path path) (get-target-path path))
+ (display (G_ " done\n"))))
+ to-create)))
+
#$%initialize-gettext
- (let* ((config-home (or (getenv "XDG_CONFIG_HOME")
- (string-append (getenv "HOME") "/.config")))
-
- (he-path (string-append (getenv "HOME") "/.guix-home"))
+ (let* ((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"))
@@ -103,141 +212,24 @@ (define ((file-tree-traverse preordering) node)
;; 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 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 (G_ "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 (G_ " done\n"))))
-
- (cleanup-symlinks
- (lambda ()
- (let ((to-delete ((file-tree-traverse #f) old-tree)))
- (display
- (G_
- "Cleaning up symlinks from previous home-environment.\n\n"))
- (map
- (match-lambda
- (('dir . ".")
- (display (G_ "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 (G_ "Removing ~a...")
- (get-target-path path))
- (rmdir (get-target-path path))
- (display (G_ " done\n")))
- (format
- #t
- (G_ "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 (G_ "Removing ~a...") (get-target-path path))
- (delete-file (get-target-path path))
- (display (G_ " done\n")))
- (format
- #t
- (G_ "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
- (G_ "New symlinks to home-environment will be created soon.\n"))
- (format
- #t (G_ "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 (G_ "Skipping ~a (directory already exists)... done\n")
- target-path)
- (begin
- (format #t (G_ "Creating ~a...") target-path)
- (mkdir target-path)
- (display (G_ " done\n"))))))
-
- (('file . path)
- (when (file-exists? (get-target-path path))
- (backup-file path))
- (format #t (G_ "Symlinking ~a -> ~a...")
- (get-target-path path) (get-source-path path))
- (symlink (get-source-path path) (get-target-path path))
- (display (G_ " done\n"))))
- to-create)))))
+ (file-system-tree new-files-dir-path))))
(when old-tree
- (cleanup-symlinks))
+ (cleanup-symlinks old-tree))
- (create-symlinks)
+ (create-symlinks new-tree new-files-path)
(symlink new-home new-he-path)
(rename-file new-he-path he-path)
(display (G_" done\nFinished updating symlinks.\n\n")))))))
-
(define (update-symlinks-gexp _)
#~(primitive-load #$(update-symlinks-script)))
--
2.34.0
^ permalink raw reply related [flat|nested] 28+ messages in thread* [bug#54180] [PATCH 02/12] home: symlink-manager: Move helper procedures as top-level defines.
2022-02-27 13:53 ` [bug#54180] [PATCH 02/12] home: symlink-manager: Move helper procedures as top-level defines Ludovic Courtès
@ 2022-02-27 15:58 ` Maxime Devos
2022-03-10 10:28 ` [bug#54180] [PATCH 00/12] Home: Clarify and better test symlink-manager.scm Ludovic Courtès
0 siblings, 1 reply; 28+ messages in thread
From: Maxime Devos @ 2022-02-27 15:58 UTC (permalink / raw)
To: Ludovic Courtès, 54180
[-- Attachment #1: Type: text/plain, Size: 440 bytes --]
Ludovic Courtès schreef op zo 27-02-2022 om 14:53 [+0100]:
> (file-exists? (get-target-path path))
> [... other uses of file-exists? ...]
'file-exists?' does not simply check whether the file exists.
E.g., when there is some permission error, then it returns #false.
I think that in case of an permission error, it would best be reported
to the user, so I think a variant of 'file-exists?' may be needed.
Greetings,
Maxime.
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply [flat|nested] 28+ messages in thread
* [bug#54180] [PATCH 00/12] Home: Clarify and better test symlink-manager.scm
2022-02-27 15:58 ` Maxime Devos
@ 2022-03-10 10:28 ` Ludovic Courtès
0 siblings, 0 replies; 28+ messages in thread
From: Ludovic Courtès @ 2022-03-10 10:28 UTC (permalink / raw)
To: Maxime Devos; +Cc: 54180
Maxime Devos <maximedevos@telenet.be> skribis:
> Ludovic Courtès schreef op zo 27-02-2022 om 14:53 [+0100]:
>> (file-exists? (get-target-path path))
>> [... other uses of file-exists? ...]
Note that this patch just shuffles code around; it does not introduce
new ‘file-exists?’ calls.
> 'file-exists?' does not simply check whether the file exists.
> E.g., when there is some permission error, then it returns #false.
>
> I think that in case of an permission error, it would best be reported
> to the user, so I think a variant of 'file-exists?' may be needed.
I believe later patches mostly address this by avoiding separate ‘stat’
calls (‘file-exists?’ is a thin wrapper around ‘stat’).
Ludo’.
^ permalink raw reply [flat|nested] 28+ messages in thread
* [bug#54180] [PATCH 03/12] home: symlink-manager: Use 'for-each' when used for effects.
2022-02-27 13:53 ` [bug#54180] [PATCH 01/12] home: symlink-manager: Clarify module imports Ludovic Courtès
2022-02-27 13:53 ` [bug#54180] [PATCH 02/12] home: symlink-manager: Move helper procedures as top-level defines Ludovic Courtès
@ 2022-02-27 13:53 ` Ludovic Courtès
2022-02-27 13:53 ` [bug#54180] [PATCH 04/12] home: symlink-manager: Use 'file-is-directory?' Ludovic Courtès
` (8 subsequent siblings)
10 siblings, 0 replies; 28+ messages in thread
From: Ludovic Courtès @ 2022-02-27 13:53 UTC (permalink / raw)
To: 54180; +Cc: Ludovic Courtès
* gnu/home/services/symlink-manager.scm (update-symlinks-script)[cleanup-symlinks]
[create-symlinks]: Use 'for-each' instead of 'map'.
---
gnu/home/services/symlink-manager.scm | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/gnu/home/services/symlink-manager.scm b/gnu/home/services/symlink-manager.scm
index 25470209d1..a6344c808f 100644
--- a/gnu/home/services/symlink-manager.scm
+++ b/gnu/home/services/symlink-manager.scm
@@ -125,7 +125,7 @@ (define (cleanup-symlinks old-tree)
(display
(G_
"Cleaning up symlinks from previous home-environment.\n\n"))
- (map
+ (for-each
(match-lambda
(('dir . ".")
(display (G_ "Cleanup finished.\n\n")))
@@ -168,7 +168,7 @@ (define (get-source-path path)
(readlink (string-append new-files-path "/" path)))
(let ((to-create ((file-tree-traverse #t) new-tree)))
- (map
+ (for-each
(match-lambda
(('dir . ".")
(display
--
2.34.0
^ permalink raw reply related [flat|nested] 28+ messages in thread* [bug#54180] [PATCH 04/12] home: symlink-manager: Use 'file-is-directory?'.
2022-02-27 13:53 ` [bug#54180] [PATCH 01/12] home: symlink-manager: Clarify module imports Ludovic Courtès
2022-02-27 13:53 ` [bug#54180] [PATCH 02/12] home: symlink-manager: Move helper procedures as top-level defines Ludovic Courtès
2022-02-27 13:53 ` [bug#54180] [PATCH 03/12] home: symlink-manager: Use 'for-each' when used for effects Ludovic Courtès
@ 2022-02-27 13:53 ` Ludovic Courtès
2022-02-27 13:53 ` [bug#54180] [PATCH 05/12] home: symlink-manager: Remove 'empty-directory?' and avoid TOCTTOU race Ludovic Courtès
` (7 subsequent siblings)
10 siblings, 0 replies; 28+ messages in thread
From: Ludovic Courtès @ 2022-02-27 13:53 UTC (permalink / raw)
To: 54180; +Cc: Ludovic Courtès
* gnu/home/services/symlink-manager.scm (update-symlinks-script)[directory?]:
Remove.
Change callers to use 'file-is-directory?' instead.
---
gnu/home/services/symlink-manager.scm | 7 ++-----
1 file changed, 2 insertions(+), 5 deletions(-)
diff --git a/gnu/home/services/symlink-manager.scm b/gnu/home/services/symlink-manager.scm
index a6344c808f..f133eb17f2 100644
--- a/gnu/home/services/symlink-manager.scm
+++ b/gnu/home/services/symlink-manager.scm
@@ -101,9 +101,6 @@ (define (get-target-path path)
(define (get-backup-path path)
(string-append backup-dir "/." path))
- (define (directory? path)
- (equal? (stat:type (stat path)) 'directory))
-
(define (empty-directory? dir)
(equal? (scandir dir) '("." "..")))
@@ -133,7 +130,7 @@ (define (cleanup-symlinks old-tree)
(('dir . path)
(if (and
(file-exists? (get-target-path path))
- (directory? (get-target-path path))
+ (file-is-directory? (get-target-path path))
(empty-directory? (get-target-path path)))
(begin
(format #t (G_ "Removing ~a...")
@@ -179,7 +176,7 @@ (define (get-source-path path)
(('dir . path)
(let ((target-path (get-target-path path)))
(when (and (file-exists? target-path)
- (not (directory? target-path)))
+ (not (file-is-directory? target-path)))
(backup-file path))
(if (file-exists? target-path)
--
2.34.0
^ permalink raw reply related [flat|nested] 28+ messages in thread* [bug#54180] [PATCH 05/12] home: symlink-manager: Remove 'empty-directory?' and avoid TOCTTOU race.
2022-02-27 13:53 ` [bug#54180] [PATCH 01/12] home: symlink-manager: Clarify module imports Ludovic Courtès
` (2 preceding siblings ...)
2022-02-27 13:53 ` [bug#54180] [PATCH 04/12] home: symlink-manager: Use 'file-is-directory?' Ludovic Courtès
@ 2022-02-27 13:53 ` Ludovic Courtès
2022-02-27 15:54 ` Maxime Devos
2022-02-27 13:53 ` [bug#54180] [PATCH 06/12] home: symlink-manager: Avoid extra 'lstat' call Ludovic Courtès
` (6 subsequent siblings)
10 siblings, 1 reply; 28+ messages in thread
From: Ludovic Courtès @ 2022-02-27 13:53 UTC (permalink / raw)
To: 54180; +Cc: Ludovic Courtès
This removes three 'stat' syscalls.
* gnu/home/services/symlink-manager.scm (update-symlinks-script)[empty-directory?]:
Remove.
[cleanup-symlinks]: Replace use of 'file-exists?', 'file-is-directory?',
and 'empty-directory?' by a single 'rmdir' call.
---
gnu/home/services/symlink-manager.scm | 35 ++++++++++++++-------------
1 file changed, 18 insertions(+), 17 deletions(-)
diff --git a/gnu/home/services/symlink-manager.scm b/gnu/home/services/symlink-manager.scm
index f133eb17f2..6b3a9de3d1 100644
--- a/gnu/home/services/symlink-manager.scm
+++ b/gnu/home/services/symlink-manager.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -101,9 +102,6 @@ (define (get-target-path path)
(define (get-backup-path path)
(string-append backup-dir "/." path))
- (define (empty-directory? dir)
- (equal? (scandir dir) '("." "..")))
-
(define (symlink-to-store? path)
(and (equal? (stat:type (lstat path)) 'symlink)
(store-file-name? (readlink path))))
@@ -127,20 +125,23 @@ (define (cleanup-symlinks old-tree)
(('dir . ".")
(display (G_ "Cleanup finished.\n\n")))
- (('dir . path)
- (if (and
- (file-exists? (get-target-path path))
- (file-is-directory? (get-target-path path))
- (empty-directory? (get-target-path path)))
- (begin
- (format #t (G_ "Removing ~a...")
- (get-target-path path))
- (rmdir (get-target-path path))
- (display (G_ " done\n")))
- (format
- #t
- (G_ "Skipping ~a (not an empty directory)... done\n")
- (get-target-path path))))
+ (('dir . directory)
+ (let ((directory (get-target-path directory)))
+ (catch 'system-error
+ (lambda ()
+ (rmdir directory)
+ (format #t (G_ "Removed ~a.\n") directory))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (cond ((= ENOTEMPTY errno)
+ (format
+ #t
+ (G_ "Skipping ~a (not an empty directory)...\n")
+ directory))
+ ((= ENOTDIR errno)
+ #t)
+ (else
+ (apply throw args))))))))
(('file . path)
(when (file-exists? (get-target-path path))
--
2.34.0
^ permalink raw reply related [flat|nested] 28+ messages in thread* [bug#54180] [PATCH 05/12] home: symlink-manager: Remove 'empty-directory?' and avoid TOCTTOU race.
2022-02-27 13:53 ` [bug#54180] [PATCH 05/12] home: symlink-manager: Remove 'empty-directory?' and avoid TOCTTOU race Ludovic Courtès
@ 2022-02-27 15:54 ` Maxime Devos
2022-03-05 22:19 ` [bug#54180] [PATCH 00/12] Home: Clarify and better test symlink-manager.scm Ludovic Courtès
0 siblings, 1 reply; 28+ messages in thread
From: Maxime Devos @ 2022-02-27 15:54 UTC (permalink / raw)
To: Ludovic Courtès, 54180
[-- Attachment #1: Type: text/plain, Size: 1542 bytes --]
Ludovic Courtès schreef op zo 27-02-2022 om 14:53 [+0100]:
> + (let ((directory (get-target-path directory)))
> + (catch 'system-error
> + (lambda ()
> + (rmdir directory)
> + (format #t (G_ "Removed ~a.\n") directory))
> + (lambda args
> + (let ((errno (system-error-errno args)))
> + (cond ((= ENOTEMPTY errno)
> + (format
> + #t
> + (G_ "Skipping ~a (not an empty directory)...\n")
> + directory))
> + ((= ENOTDIR errno)
> + #t)
> + (else
> + (apply throw args))))))))
Like with my comment on ‘Avoid extra 'lstat call.’, I would move the
(format #t (G_ "Removed ~a.\n") directory) outside the catch.
If 'format' somehow throws a ENOTEMPTY/ENOTDIR system-error, something
is very wrong.
Greetings,
Maxime.
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply [flat|nested] 28+ messages in thread
* [bug#54180] [PATCH 00/12] Home: Clarify and better test symlink-manager.scm
2022-02-27 15:54 ` Maxime Devos
@ 2022-03-05 22:19 ` Ludovic Courtès
2022-03-05 22:37 ` Maxime Devos
0 siblings, 1 reply; 28+ messages in thread
From: Ludovic Courtès @ 2022-03-05 22:19 UTC (permalink / raw)
To: Maxime Devos; +Cc: 54180
Maxime Devos <maximedevos@telenet.be> skribis:
> Ludovic Courtès schreef op zo 27-02-2022 om 14:53 [+0100]:
>> + (let ((directory (get-target-path directory)))
>> + (catch 'system-error
>> + (lambda ()
>> + (rmdir directory)
>> + (format #t (G_ "Removed ~a.\n") directory))
>> + (lambda args
>> + (let ((errno (system-error-errno args)))
>> + (cond ((= ENOTEMPTY errno)
>> + (format
>> + #t
>> + (G_ "Skipping ~a (not an empty directory)...\n")
>> + directory))
>> + ((= ENOTDIR errno)
>> + #t)
>> + (else
>> + (apply throw args))))))))
>
> Like with my comment on ‘Avoid extra 'lstat call.’, I would move the
> (format #t (G_ "Removed ~a.\n") directory) outside the catch.
>
> If 'format' somehow throws a ENOTEMPTY/ENOTDIR system-error, something
> is very wrong.
Precisely: we can keep the ‘format’ call after ‘rmdir’ because we know
(1) it’s only going to be called if ‘rmdir’ succeeds, and (2) it won’t
throw to ‘system-error’.
^ permalink raw reply [flat|nested] 28+ messages in thread
* [bug#54180] [PATCH 00/12] Home: Clarify and better test symlink-manager.scm
2022-03-05 22:19 ` [bug#54180] [PATCH 00/12] Home: Clarify and better test symlink-manager.scm Ludovic Courtès
@ 2022-03-05 22:37 ` Maxime Devos
0 siblings, 0 replies; 28+ messages in thread
From: Maxime Devos @ 2022-03-05 22:37 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 54180
[-- Attachment #1: Type: text/plain, Size: 1185 bytes --]
Ludovic Courtès schreef op za 05-03-2022 om 23:19 [+0100]:
> > Like with my comment on ‘Avoid extra 'lstat call.’, I would move
> > the
> > (format #t (G_ "Removed ~a.\n") directory) outside the catch.
> >
> > If 'format' somehow throws a ENOTEMPTY/ENOTDIR system-error,
> > something
> > is very wrong.
>
> Precisely: we can keep the ‘format’ call after ‘rmdir’ because we
> know (1) it’s only going to be called if ‘rmdir’ succeeds, and (2) it
> won’t throw to ‘system-error’.
Yes, we could keep it inside the 'catch', but that doesn't it's a good
idea, because if format throws a ENOTEMPTY/ENOTDIR, shouldn't that be
reported because that seems very wrong?
WDYT of
(define (delete-if-empty file)
;; Returns #t if deleted, #f if skipped because empty
(catch ... (lambda () (rmdir directory) #t)
(lambda ...
(cond ((= ENOTEMPTY ...) #false)
((= ENOTDIR ...)
[TODO: if it was a regular file, shouldn't it still be deleted?])
(#true (throw ...))))))
(if (delete-if-empty)
(format ... "removed ...")
(format ... "skipped ..."))
?
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply [flat|nested] 28+ messages in thread
* [bug#54180] [PATCH 06/12] home: symlink-manager: Avoid extra 'lstat' call.
2022-02-27 13:53 ` [bug#54180] [PATCH 01/12] home: symlink-manager: Clarify module imports Ludovic Courtès
` (3 preceding siblings ...)
2022-02-27 13:53 ` [bug#54180] [PATCH 05/12] home: symlink-manager: Remove 'empty-directory?' and avoid TOCTTOU race Ludovic Courtès
@ 2022-02-27 13:53 ` Ludovic Courtès
2022-02-27 15:52 ` Maxime Devos
2022-02-27 13:53 ` [bug#54180] [PATCH 07/12] tests: Make sure 'guix home reconfigure' backs up files Ludovic Courtès
` (5 subsequent siblings)
10 siblings, 1 reply; 28+ messages in thread
From: Ludovic Courtès @ 2022-02-27 13:53 UTC (permalink / raw)
To: 54180; +Cc: Ludovic Courtès
* gnu/home/services/symlink-manager.scm (update-symlinks-script)[symlink-to-store?]:
Avoid extra 'lstat' call.
---
gnu/home/services/symlink-manager.scm | 9 +++++++--
1 file changed, 7 insertions(+), 2 deletions(-)
diff --git a/gnu/home/services/symlink-manager.scm b/gnu/home/services/symlink-manager.scm
index 6b3a9de3d1..ba42424e8e 100644
--- a/gnu/home/services/symlink-manager.scm
+++ b/gnu/home/services/symlink-manager.scm
@@ -103,8 +103,13 @@ (define (get-backup-path path)
(string-append backup-dir "/." path))
(define (symlink-to-store? path)
- (and (equal? (stat:type (lstat path)) 'symlink)
- (store-file-name? (readlink path))))
+ (catch 'system-error
+ (lambda ()
+ (store-file-name? (readlink path)))
+ (lambda args
+ (if (= EINVAL (system-error-errno args))
+ #f
+ (apply throw args)))))
(define (backup-file path)
(mkdir-p backup-dir)
--
2.34.0
^ permalink raw reply related [flat|nested] 28+ messages in thread* [bug#54180] [PATCH 07/12] tests: Make sure 'guix home reconfigure' backs up files.
2022-02-27 13:53 ` [bug#54180] [PATCH 01/12] home: symlink-manager: Clarify module imports Ludovic Courtès
` (4 preceding siblings ...)
2022-02-27 13:53 ` [bug#54180] [PATCH 06/12] home: symlink-manager: Avoid extra 'lstat' call Ludovic Courtès
@ 2022-02-27 13:53 ` Ludovic Courtès
2022-02-27 13:53 ` [bug#54180] [PATCH 08/12] tests: Simplify use of 'local-file' in 'tests/guix-home.sh' Ludovic Courtès
` (4 subsequent siblings)
10 siblings, 0 replies; 28+ messages in thread
From: Ludovic Courtès @ 2022-02-27 13:53 UTC (permalink / raw)
To: 54180; +Cc: Ludovic Courtès
* tests/guix-home.sh: Create ~/.bashrc and ~/.config/test.conf prior to
'reconfigure' and check whether they were backed up.
---
tests/guix-home.sh | 16 ++++++++++++++--
1 file changed, 14 insertions(+), 2 deletions(-)
diff --git a/tests/guix-home.sh b/tests/guix-home.sh
index e578559c97..ae3e52c9e1 100644
--- a/tests/guix-home.sh
+++ b/tests/guix-home.sh
@@ -1,7 +1,7 @@
-
# GNU Guix --- Functional package management for GNU
# Copyright © 2021 Andrew Tropin <andrew@trop.in>
# Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com>
+# Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
@@ -54,7 +54,12 @@ trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT
# Test 'guix home reconfigure'.
#
- printf "# dot-bashrc test file for guix home" > "dot-bashrc"
+ echo "# This file will be overridden and backed up." > "$HOME/.bashrc"
+ mkdir "$HOME/.config"
+ echo "This file will be overridden too." > "$HOME/.config/test.conf"
+ echo "This file will stay around." > "$HOME/.config/random-file"
+
+ echo -n "# dot-bashrc test file for guix home" > "dot-bashrc"
cat > "home.scm" <<'EOF'
(use-modules (guix gexp)
@@ -100,6 +105,13 @@ EOF
# the content of bashrc-test-config.sh"
grep -q "the content of ~/.config/test.conf" "${HOME}/.config/test.conf"
+ # This one should still be here.
+ grep "stay around" "$HOME/.config/random-file"
+
+ # Make sure preexisting files were backed up.
+ grep "overridden" "$HOME"/*guix-home*backup/.bashrc
+ grep "overridden" "$HOME"/*guix-home*backup/.config/test.conf
+
#
# Test 'guix home describe'.
#
--
2.34.0
^ permalink raw reply related [flat|nested] 28+ messages in thread* [bug#54180] [PATCH 08/12] tests: Simplify use of 'local-file' in 'tests/guix-home.sh'.
2022-02-27 13:53 ` [bug#54180] [PATCH 01/12] home: symlink-manager: Clarify module imports Ludovic Courtès
` (5 preceding siblings ...)
2022-02-27 13:53 ` [bug#54180] [PATCH 07/12] tests: Make sure 'guix home reconfigure' backs up files Ludovic Courtès
@ 2022-02-27 13:53 ` Ludovic Courtès
2022-02-27 13:53 ` [bug#54180] [PATCH 09/12] tests: Check 'guix home reconfigure' for a second generation Ludovic Courtès
` (3 subsequent siblings)
10 siblings, 0 replies; 28+ messages in thread
From: Ludovic Courtès @ 2022-02-27 13:53 UTC (permalink / raw)
To: 54180; +Cc: Ludovic Courtès
* tests/guix-home.sh: Remove 'current-filename' trickery since
'local-file' resolves file names relative to the containing file.
---
tests/guix-home.sh | 5 +----
1 file changed, 1 insertion(+), 4 deletions(-)
diff --git a/tests/guix-home.sh b/tests/guix-home.sh
index ae3e52c9e1..3b397649cc 100644
--- a/tests/guix-home.sh
+++ b/tests/guix-home.sh
@@ -81,10 +81,7 @@ trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT
(service home-bash-service-type
(home-bash-configuration
(guix-defaults? #t)
- (bashrc
- (list
- (local-file (string-append (dirname (current-filename))
- "/dot-bashrc"))))))
+ (bashrc (list (local-file "dot-bashrc")))))
(simple-service 'home-bash-service-extension-test
home-bash-service-type
--
2.34.0
^ permalink raw reply related [flat|nested] 28+ messages in thread* [bug#54180] [PATCH 09/12] tests: Check 'guix home reconfigure' for a second generation.
2022-02-27 13:53 ` [bug#54180] [PATCH 01/12] home: symlink-manager: Clarify module imports Ludovic Courtès
` (6 preceding siblings ...)
2022-02-27 13:53 ` [bug#54180] [PATCH 08/12] tests: Simplify use of 'local-file' in 'tests/guix-home.sh' Ludovic Courtès
@ 2022-02-27 13:53 ` Ludovic Courtès
2022-02-27 15:49 ` Maxime Devos
2022-02-27 13:53 ` [bug#54180] [PATCH 10/12] home: symlink-manager: 'cleanup-symlinks' uses 'file-system-fold' Ludovic Courtès
` (2 subsequent siblings)
10 siblings, 1 reply; 28+ messages in thread
From: Ludovic Courtès @ 2022-02-27 13:53 UTC (permalink / raw)
To: 54180; +Cc: Ludovic Courtès
* tests/guix-home.sh: Invoke "guix home reconfigure" a second time with
a modify config file and check the result.
---
tests/guix-home.sh | 23 +++++++++++++++++++++++
1 file changed, 23 insertions(+)
diff --git a/tests/guix-home.sh b/tests/guix-home.sh
index 3b397649cc..f054d15172 100644
--- a/tests/guix-home.sh
+++ b/tests/guix-home.sh
@@ -108,6 +108,7 @@ EOF
# Make sure preexisting files were backed up.
grep "overridden" "$HOME"/*guix-home*backup/.bashrc
grep "overridden" "$HOME"/*guix-home*backup/.config/test.conf
+ rm -r "$HOME"/*guix-home*backup
#
# Test 'guix home describe'.
@@ -131,6 +132,28 @@ EOF
}
test "$(canonical_file_name)" == "$(readlink "${HOME}/.guix-home")"
+ #
+ # Configure a new generation.
+ #
+
+ # Change the bashrc snippet content and comment out one service.
+ sed -i "home.scm" -e's/the content of/the NEW content of/g'
+ sed -i "home.scm" -e"s/(simple-service 'test-config/#;(simple-service 'test-config/g"
+
+ guix home reconfigure "${test_directory}/home.scm"
+ test "$(tail -n 2 "${HOME}/.bashrc")" == "\
+# dot-bashrc test file for guix home
+# the NEW content of bashrc-test-config.sh"
+
+ # This file must have been removed and not backed up.
+ ! test -e "$HOME/.config/test.conf"
+ ! test -e "$HOME"/*guix-home*backup/.config/test.conf
+
+ test "$(cat "$(configuration_file)")" == "$(cat home.scm)"
+ test "$(canonical_file_name)" == "$(readlink "${HOME}/.guix-home")"
+
+ test $(guix home list-generations | grep "^Generation" | wc -l) -eq 2
+
#
# Test 'guix home search'.
#
--
2.34.0
^ permalink raw reply related [flat|nested] 28+ messages in thread* [bug#54180] [PATCH 09/12] tests: Check 'guix home reconfigure' for a second generation.
2022-02-27 13:53 ` [bug#54180] [PATCH 09/12] tests: Check 'guix home reconfigure' for a second generation Ludovic Courtès
@ 2022-02-27 15:49 ` Maxime Devos
2022-03-05 22:20 ` [bug#54180] [PATCH 00/12] Home: Clarify and better test symlink-manager.scm Ludovic Courtès
0 siblings, 1 reply; 28+ messages in thread
From: Maxime Devos @ 2022-02-27 15:49 UTC (permalink / raw)
To: Ludovic Courtès, 54180
[-- Attachment #1: Type: text/plain, Size: 496 bytes --]
Ludovic Courtès schreef op zo 27-02-2022 om 14:53 [+0100]:
> * tests/guix-home.sh: Invoke "guix home reconfigure" a second time with
> a modify config file and check the result.
Something I don't understand, is why these tests are bash scripts in
the first place.
Wouldn't Scheme code suffice and be easier to reason about? For
example, Scheme code would avoid repeating the complicated code for
starting a daemon and making sure it exits in every .sh test.
Greetings
Maxime.
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply [flat|nested] 28+ messages in thread
* [bug#54180] [PATCH 00/12] Home: Clarify and better test symlink-manager.scm
2022-02-27 15:49 ` Maxime Devos
@ 2022-03-05 22:20 ` Ludovic Courtès
2022-03-05 22:27 ` Maxime Devos
0 siblings, 1 reply; 28+ messages in thread
From: Ludovic Courtès @ 2022-03-05 22:20 UTC (permalink / raw)
To: Maxime Devos; +Cc: 54180
Maxime Devos <maximedevos@telenet.be> skribis:
> Ludovic Courtès schreef op zo 27-02-2022 om 14:53 [+0100]:
>> * tests/guix-home.sh: Invoke "guix home reconfigure" a second time with
>> a modify config file and check the result.
>
> Something I don't understand, is why these tests are bash scripts in
> the first place.
>
> Wouldn't Scheme code suffice and be easier to reason about? For
> example, Scheme code would avoid repeating the complicated code for
> starting a daemon and making sure it exits in every .sh test.
It’s useful to have integration tests that exercise the commands; unit
tests would also be welcome, but that’s what we have so far.
^ permalink raw reply [flat|nested] 28+ messages in thread
* [bug#54180] [PATCH 00/12] Home: Clarify and better test symlink-manager.scm
2022-03-05 22:20 ` [bug#54180] [PATCH 00/12] Home: Clarify and better test symlink-manager.scm Ludovic Courtès
@ 2022-03-05 22:27 ` Maxime Devos
2022-03-05 22:38 ` Maxime Devos
2022-03-10 10:23 ` Ludovic Courtès
0 siblings, 2 replies; 28+ messages in thread
From: Maxime Devos @ 2022-03-05 22:27 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 54180
[-- Attachment #1: Type: text/plain, Size: 433 bytes --]
Ludovic Courtès schreef op za 05-03-2022 om 23:20 [+0100]:
> It’s useful to have integration tests that exercise the commands; unit
> tests would also be welcome, but that’s what we have so far.
Integreation tests don't have to be in bash. We can have integration
tests in Scheme, by running the 'guix-FOO' procedures from (guix
scripts ...), like tests/substitute.scm and tests/publish.scm do.
Greetings,
Maxime.
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply [flat|nested] 28+ messages in thread
* [bug#54180] [PATCH 00/12] Home: Clarify and better test symlink-manager.scm
2022-03-05 22:27 ` Maxime Devos
@ 2022-03-05 22:38 ` Maxime Devos
2022-03-10 10:24 ` Ludovic Courtès
2022-03-10 10:23 ` Ludovic Courtès
1 sibling, 1 reply; 28+ messages in thread
From: Maxime Devos @ 2022-03-05 22:38 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 54180
[-- Attachment #1: Type: text/plain, Size: 675 bytes --]
p.s., I'm getting ‘Undelivered Mail Returned to Sender’:
This is the mail system at host taslin.fdn.fr.
I'm sorry to have to inform you that your message could not
be delivered to one or more recipients. It's attached below.
For further assistance, please send mail to postmaster.
If you do so, please include this problem report. You can
delete your own text from the attached returned message.
The mail system
<lcourtes@fdn.fr> (expanded from <ludovic.courtes@fdn.fr>): host
taslin.fdn.fr[private/dovecot-lmtp] said: 552 5.2.2
<lcourtes@fdn.fr> Quota
exceeded, please contact vlp. (in reply to end of DATA command)
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply [flat|nested] 28+ messages in thread* [bug#54180] [PATCH 00/12] Home: Clarify and better test symlink-manager.scm
2022-03-05 22:38 ` Maxime Devos
@ 2022-03-10 10:24 ` Ludovic Courtès
0 siblings, 0 replies; 28+ messages in thread
From: Ludovic Courtès @ 2022-03-10 10:24 UTC (permalink / raw)
To: Maxime Devos; +Cc: 54180
Maxime Devos <maximedevos@telenet.be> skribis:
> p.s., I'm getting ‘Undelivered Mail Returned to Sender’:
I think that’s solved, but my mail setup is still in flux… Don’t
hesitate to ping me on IRC or something if you think I might have missed
a message of yours.
Ludo’.
^ permalink raw reply [flat|nested] 28+ messages in thread
* [bug#54180] [PATCH 00/12] Home: Clarify and better test symlink-manager.scm
2022-03-05 22:27 ` Maxime Devos
2022-03-05 22:38 ` Maxime Devos
@ 2022-03-10 10:23 ` Ludovic Courtès
1 sibling, 0 replies; 28+ messages in thread
From: Ludovic Courtès @ 2022-03-10 10:23 UTC (permalink / raw)
To: Maxime Devos; +Cc: 54180
Hi Maxime,
Maxime Devos <maximedevos@telenet.be> skribis:
> Ludovic Courtès schreef op za 05-03-2022 om 23:20 [+0100]:
>> It’s useful to have integration tests that exercise the commands; unit
>> tests would also be welcome, but that’s what we have so far.
>
> Integreation tests don't have to be in bash. We can have integration
> tests in Scheme, by running the 'guix-FOO' procedures from (guix
> scripts ...), like tests/substitute.scm and tests/publish.scm do.
Yes, you’re right, but this patch series is not about rewriting the
integration tests. :-)
The way I see it, we can choose and combine different strategies: Bash
tests (the good thing is that they’re as close as can be to what users
run), Scheme integration tests like you write when more fine-grain
control is needed, and of course unit tests.
Ludo’.
^ permalink raw reply [flat|nested] 28+ messages in thread
* [bug#54180] [PATCH 10/12] home: symlink-manager: 'cleanup-symlinks' uses 'file-system-fold'.
2022-02-27 13:53 ` [bug#54180] [PATCH 01/12] home: symlink-manager: Clarify module imports Ludovic Courtès
` (7 preceding siblings ...)
2022-02-27 13:53 ` [bug#54180] [PATCH 09/12] tests: Check 'guix home reconfigure' for a second generation Ludovic Courtès
@ 2022-02-27 13:53 ` Ludovic Courtès
2022-02-27 13:53 ` [bug#54180] [PATCH 11/12] home: symlink-manager: 'create-symlinks' " Ludovic Courtès
2022-02-27 13:53 ` [bug#54180] [PATCH 12/12] home: symlink-manager: Rename "path" to "file" where appropriate Ludovic Courtès
10 siblings, 0 replies; 28+ messages in thread
From: Ludovic Courtès @ 2022-02-27 13:53 UTC (permalink / raw)
To: 54180; +Cc: Ludovic Courtès
* gnu/home/services/symlink-manager.scm (update-symlinks-script)[cleanup-symlinks]:
Take a home generation and iterate over its config files directly with
'file-system-fold'. Adjuster caller accordingly. Remove 'old-tree'.
---
gnu/home/services/symlink-manager.scm | 107 ++++++++++++++------------
1 file changed, 57 insertions(+), 50 deletions(-)
diff --git a/gnu/home/services/symlink-manager.scm b/gnu/home/services/symlink-manager.scm
index ba42424e8e..4f827c0360 100644
--- a/gnu/home/services/symlink-manager.scm
+++ b/gnu/home/services/symlink-manager.scm
@@ -118,51 +118,63 @@ (define (backup-file path)
(rename-file (get-target-path path) (get-backup-path path))
(display (G_ " done\n")))
- (define (cleanup-symlinks old-tree)
- ;; Delete from directory OLD-TREE symlinks that correspond to a
- ;; previous generation.
- (let ((to-delete ((file-tree-traverse #f) old-tree)))
- (display
- (G_
- "Cleaning up symlinks from previous home-environment.\n\n"))
- (for-each
- (match-lambda
- (('dir . ".")
- (display (G_ "Cleanup finished.\n\n")))
+ (define (cleanup-symlinks home-generation)
+ ;; Delete from $HOME files that originate in HOME-GENERATION, the
+ ;; store item containing a home generation.
+ (define config-file-directory
+ ;; Note: Trailing slash is needed because "files" is a symlink.
+ (string-append home-generation "/files/"))
- (('dir . directory)
- (let ((directory (get-target-path directory)))
- (catch 'system-error
- (lambda ()
- (rmdir directory)
- (format #t (G_ "Removed ~a.\n") directory))
- (lambda args
- (let ((errno (system-error-errno args)))
- (cond ((= ENOTEMPTY errno)
- (format
- #t
- (G_ "Skipping ~a (not an empty directory)...\n")
- directory))
- ((= ENOTDIR errno)
- #t)
- (else
- (apply throw args))))))))
+ (define (strip file)
+ (string-drop file
+ (+ 1 (string-length config-file-directory))))
- (('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 (G_ "Removing ~a...") (get-target-path path))
- (delete-file (get-target-path path))
- (display (G_ " done\n")))
- (format
- #t
- (G_ "Skipping ~a (not a symlink to store)... done\n")
- (get-target-path path))))))
- to-delete)))
+ (format #t (G_ "Cleaning up symlinks from previous home at ~a.~%")
+ home-generation)
+ (newline)
+
+ (file-system-fold
+ (const #t)
+ (lambda (file stat _) ;leaf
+ (let ((file (get-target-path (strip file))))
+ (when (file-exists? file)
+ ;; 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? file)
+ (begin
+ (format #t (G_ "Removing ~a...") file)
+ (delete-file file)
+ (display (G_ " done\n")))
+ (format #t
+ (G_ "Skipping ~a (not a symlink to store)... done\n")
+ file)))))
+
+ (const #t) ;down
+ (lambda (directory stat _) ;up
+ (unless (string=? directory config-file-directory)
+ (let ((directory (get-target-path (strip directory))))
+ (catch 'system-error
+ (lambda ()
+ (rmdir directory)
+ (format #t (G_ "Removed ~a.\n") directory))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (cond ((= ENOTEMPTY errno)
+ (format
+ #t
+ (G_ "Skipping ~a (not an empty directory)...\n")
+ directory))
+ ((= ENOTDIR errno) #t)
+ (else
+ (apply throw args)))))))))
+ (const #t) ;skip
+ (const #t) ;error
+ #t ;init
+ config-file-directory
+ lstat)
+
+ (display (G_ "Cleanup finished.\n\n")))
(define (create-symlinks new-tree new-files-path)
;; Create in directory NEW-TREE symlinks to the files under
@@ -215,16 +227,11 @@ (define (get-source-path path)
;; to make file-system-tree works it should be a directory.
(new-files-dir-path (string-append new-files-path "/."))
- (old-tree (if 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))))
- (when old-tree
- (cleanup-symlinks old-tree))
+ (when old-home
+ (cleanup-symlinks old-home))
(create-symlinks new-tree new-files-path)
--
2.34.0
^ permalink raw reply related [flat|nested] 28+ messages in thread* [bug#54180] [PATCH 11/12] home: symlink-manager: 'create-symlinks' uses 'file-system-fold'.
2022-02-27 13:53 ` [bug#54180] [PATCH 01/12] home: symlink-manager: Clarify module imports Ludovic Courtès
` (8 preceding siblings ...)
2022-02-27 13:53 ` [bug#54180] [PATCH 10/12] home: symlink-manager: 'cleanup-symlinks' uses 'file-system-fold' Ludovic Courtès
@ 2022-02-27 13:53 ` Ludovic Courtès
2022-02-27 16:00 ` Maxime Devos
2022-02-27 13:53 ` [bug#54180] [PATCH 12/12] home: symlink-manager: Rename "path" to "file" where appropriate Ludovic Courtès
10 siblings, 1 reply; 28+ messages in thread
From: Ludovic Courtès @ 2022-02-27 13:53 UTC (permalink / raw)
To: 54180; +Cc: Ludovic Courtès
This removes the need for two intermediate representations of the file
tree.
* gnu/home/services/symlink-manager.scm (update-symlinks-script)
[simplify-file-tree, file-tree-traverse]: Remove.
[create-symlinks]: Rewrite in terms of 'file-system-fold'.
---
gnu/home/services/symlink-manager.scm | 130 +++++++++-----------------
1 file changed, 44 insertions(+), 86 deletions(-)
diff --git a/gnu/home/services/symlink-manager.scm b/gnu/home/services/symlink-manager.scm
index 4f827c0360..16e2e7b772 100644
--- a/gnu/home/services/symlink-manager.scm
+++ b/gnu/home/services/symlink-manager.scm
@@ -43,52 +43,11 @@ (define (update-symlinks-script)
(guix i18n)))
#~(begin
(use-modules (ice-9 ftw)
- (ice-9 curried-definitions)
(ice-9 match)
(srfi srfi-1)
(guix i18n)
(guix build utils))
- (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))))))
-
(define home-path
(getenv "HOME"))
@@ -176,64 +135,63 @@ (define (strip file)
(display (G_ "Cleanup finished.\n\n")))
- (define (create-symlinks new-tree new-files-path)
- ;; Create in directory NEW-TREE symlinks to the files under
- ;; NEW-FILES-PATH, creating backups as needed.
+ (define (create-symlinks home-generation)
+ ;; Create in $HOME symlinks for the files in HOME-GENERATION.
+ (define config-file-directory
+ ;; Note: Trailing slash is needed because "files" is a symlink.
+ (string-append home-generation "/files/"))
+
+ (define (strip file)
+ (string-drop file
+ (+ 1 (string-length config-file-directory))))
+
(define (get-source-path path)
- (readlink (string-append new-files-path "/" path)))
+ (readlink (string-append config-file-directory path)))
- (let ((to-create ((file-tree-traverse #t) new-tree)))
- (for-each
- (match-lambda
- (('dir . ".")
- (display
- (G_ "New symlinks to home-environment will be created soon.\n"))
- (format
- #t (G_ "All conflicting files will go to ~a.\n\n") backup-dir))
+ (file-system-fold
+ (const #t) ;enter?
+ (lambda (file stat result) ;leaf
+ (let ((source (get-source-path (strip file)))
+ (target (get-target-path (strip file))))
+ (when (file-exists? target)
+ (backup-file (strip file)))
+ (format #t (G_ "Symlinking ~a -> ~a...")
+ target source)
+ (symlink source target)
+ (display (G_ " done\n"))))
+ (lambda (directory stat result) ;down
+ (unless (string=? directory config-file-directory)
+ (let ((target (get-target-path (strip directory))))
+ (when (and (file-exists? target)
+ (not (file-is-directory? target)))
+ (backup-file (strip directory)))
- (('dir . path)
- (let ((target-path (get-target-path path)))
- (when (and (file-exists? target-path)
- (not (file-is-directory? target-path)))
- (backup-file path))
-
- (if (file-exists? target-path)
- (format
- #t (G_ "Skipping ~a (directory already exists)... done\n")
- target-path)
- (begin
- (format #t (G_ "Creating ~a...") target-path)
- (mkdir target-path)
- (display (G_ " done\n"))))))
-
- (('file . path)
- (when (file-exists? (get-target-path path))
- (backup-file path))
- (format #t (G_ "Symlinking ~a -> ~a...")
- (get-target-path path) (get-source-path path))
- (symlink (get-source-path path) (get-target-path path))
- (display (G_ " done\n"))))
- to-create)))
+ (catch 'system-error
+ (lambda ()
+ (mkdir target))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (unless (= EEXIST errno)
+ (format #t (G_ "failed to create directory ~a: ~s~%")
+ target (strerror errno))
+ (apply throw args))))))))
+ (const #t) ;up
+ (const #t) ;skip
+ (const #t) ;error
+ #t ;init
+ config-file-directory))
#$%initialize-gettext
(let* ((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 "/."))
-
- (new-tree ((simplify-file-tree "")
- (file-system-tree new-files-dir-path))))
+ (old-home (getenv "GUIX_OLD_HOME")))
(when old-home
(cleanup-symlinks old-home))
- (create-symlinks new-tree new-files-path)
+ (create-symlinks new-home)
(symlink new-home new-he-path)
(rename-file new-he-path he-path)
--
2.34.0
^ permalink raw reply related [flat|nested] 28+ messages in thread* [bug#54180] [PATCH 12/12] home: symlink-manager: Rename "path" to "file" where appropriate.
2022-02-27 13:53 ` [bug#54180] [PATCH 01/12] home: symlink-manager: Clarify module imports Ludovic Courtès
` (9 preceding siblings ...)
2022-02-27 13:53 ` [bug#54180] [PATCH 11/12] home: symlink-manager: 'create-symlinks' " Ludovic Courtès
@ 2022-02-27 13:53 ` Ludovic Courtès
10 siblings, 0 replies; 28+ messages in thread
From: Ludovic Courtès @ 2022-02-27 13:53 UTC (permalink / raw)
To: 54180; +Cc: Ludovic Courtès
* gnu/home/services/symlink-manager.scm (update-symlinks-script):
[home-path]: Rename to...
[home-directory]: ... this. Adjust users.
[backup-dir]: Rename to...
[backup-directory]: ... this. Adjust user.
[get-target-path]: Rename to...
[target-file]: ... this. Adjust users.
[get-backup-path]: Remove.
[backup-file]: Inline it.
[cleanup-symlinks](get-source-path): Rename to...
(source-file): ... this. Adjust users.
Rename 'he-path' to 'home' and 'new-he-path' to 'pivot'.
---
gnu/home/services/symlink-manager.scm | 55 ++++++++++++++-------------
1 file changed, 28 insertions(+), 27 deletions(-)
diff --git a/gnu/home/services/symlink-manager.scm b/gnu/home/services/symlink-manager.scm
index 16e2e7b772..767b1bdc01 100644
--- a/gnu/home/services/symlink-manager.scm
+++ b/gnu/home/services/symlink-manager.scm
@@ -48,33 +48,35 @@ (define (update-symlinks-script)
(guix i18n)
(guix build utils))
- (define home-path
+ (define home-directory
(getenv "HOME"))
- (define backup-dir
- (string-append home-path "/" (number->string (current-time))
+ (define backup-directory
+ (string-append home-directory "/" (number->string (current-time))
"-guix-home-legacy-configs-backup"))
- (define (get-target-path path)
- (string-append home-path "/." path))
+ (define (target-file file)
+ ;; Return the target of FILE, a config file name sans leading dot
+ ;; such as "config/fontconfig/fonts.conf" or "bashrc".
+ (string-append home-directory "/." file))
- (define (get-backup-path path)
- (string-append backup-dir "/." path))
-
- (define (symlink-to-store? path)
+ (define (symlink-to-store? file)
(catch 'system-error
(lambda ()
- (store-file-name? (readlink path)))
+ (store-file-name? (readlink file)))
(lambda args
(if (= EINVAL (system-error-errno args))
#f
(apply throw args)))))
- (define (backup-file path)
- (mkdir-p backup-dir)
- (format #t (G_ "Backing up ~a...") (get-target-path path))
- (mkdir-p (dirname (get-backup-path path)))
- (rename-file (get-target-path path) (get-backup-path path))
+ (define (backup-file file)
+ (define backup
+ (string-append backup-directory "/." file))
+
+ (mkdir-p backup-directory)
+ (format #t (G_ "Backing up ~a...") (target-file file))
+ (mkdir-p (dirname backup))
+ (rename-file (target-file file) backup)
(display (G_ " done\n")))
(define (cleanup-symlinks home-generation)
@@ -95,7 +97,7 @@ (define (strip file)
(file-system-fold
(const #t)
(lambda (file stat _) ;leaf
- (let ((file (get-target-path (strip file))))
+ (let ((file (target-file (strip file))))
(when (file-exists? file)
;; DO NOT remove the file if it is no longer a symlink to
;; the store, it will be backed up later during
@@ -112,7 +114,7 @@ (define (strip file)
(const #t) ;down
(lambda (directory stat _) ;up
(unless (string=? directory config-file-directory)
- (let ((directory (get-target-path (strip directory))))
+ (let ((directory (target-file (strip directory))))
(catch 'system-error
(lambda ()
(rmdir directory)
@@ -145,14 +147,14 @@ (define (strip file)
(string-drop file
(+ 1 (string-length config-file-directory))))
- (define (get-source-path path)
- (readlink (string-append config-file-directory path)))
+ (define (source-file file)
+ (readlink (string-append config-file-directory file)))
(file-system-fold
(const #t) ;enter?
(lambda (file stat result) ;leaf
- (let ((source (get-source-path (strip file)))
- (target (get-target-path (strip file))))
+ (let ((source (source-file (strip file)))
+ (target (target-file (strip file))))
(when (file-exists? target)
(backup-file (strip file)))
(format #t (G_ "Symlinking ~a -> ~a...")
@@ -161,7 +163,7 @@ (define (get-source-path path)
(display (G_ " done\n"))))
(lambda (directory stat result) ;down
(unless (string=? directory config-file-directory)
- (let ((target (get-target-path (strip directory))))
+ (let ((target (target-file (strip directory))))
(when (and (file-exists? target)
(not (file-is-directory? target)))
(backup-file (strip directory)))
@@ -183,18 +185,17 @@ (define (get-source-path path)
#$%initialize-gettext
- (let* ((he-path (string-append (getenv "HOME") "/.guix-home"))
- (new-he-path (string-append he-path ".new"))
+ (let* ((home (string-append (getenv "HOME") "/.guix-home"))
+ (pivot (string-append home ".new"))
(new-home (getenv "GUIX_NEW_HOME"))
(old-home (getenv "GUIX_OLD_HOME")))
-
(when old-home
(cleanup-symlinks old-home))
(create-symlinks new-home)
- (symlink new-home new-he-path)
- (rename-file new-he-path he-path)
+ (symlink new-home pivot)
+ (rename-file pivot home)
(display (G_" done\nFinished updating symlinks.\n\n")))))))
--
2.34.0
^ permalink raw reply related [flat|nested] 28+ messages in thread