bug#26353: GuixSD /tmp cleaner fails to clean when Umlauts like "ä" are used in filenames

[Ludovic Courtès]

Danny Milosavljevic <address@hidden> skribis:

>> The problem of how to deal with file name encoding has been discussed on
>> the Guile side so hopefully the next release in the 2.2 series will have
>> a solution for this.
>
> Hmm, any news on this?  I've again got some immortal files in /tmp ...

I’m afraid no.  Months ago a solution was proposed on the Guile side but
not implemented.

I tried the attached workaround, which attempts to use are UTF-8-only
syscalls wrappers for the task.  Unfortunately it doesn’t work because
the cleanup code runs on the initrd’s statically-linked Guile, where
‘dynamic-link’ calls used in (guix build syscalls) fail.  :-/

Ideas?

Ludo’.

diff --git a/gnu/services.scm b/gnu/services.scm
index 016ff08e0..7d9fd132f 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -361,9 +361,12 @@ directory."
   "Return as a monadic value a gexp to clean up /tmp and similar places upon
 boot."
   (with-monad %store-monad
-    (with-imported-modules '((guix build utils))
+    (with-imported-modules (source-module-closure
+                            '((guix build utils)
+                              (guix build syscalls)))
       (return #~(begin
-                  (use-modules (guix build utils))
+                  (use-modules (guix build utils)
+                               (guix build syscalls))
 
                   ;; Clean out /tmp and /var/run.
                   ;;
@@ -387,8 +390,12 @@ boot."
                      (delete-file "/etc/passwd.lock")
                      (delete-file "/etc/.pwd.lock") ;from 'lckpwdf'
 
-                     (delete-file-recursively "/tmp")
-                     (delete-file-recursively "/var/run")
+                     ;; Assume file names are UTF-8 encoded.  See
+                     ;; <https://bugs.gnu.org/26353>.
+                     (with-utf8-file-names
+                      (delete-file-recursively "/tmp")
+                      (delete-file-recursively "/var/run"))
+
                      (mkdir "/tmp")
                      (chmod "/tmp" #o1777)
                      (mkdir "/var/run")
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index 1bc7a7027..3cec5af7f 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -29,6 +29,8 @@
   #:use-module (gnu services mcron)
   #:use-module (gnu services shepherd)
   #:use-module (gnu services networking)
+  #:use-module (gnu packages base)
+  #:use-module (gnu packages bash)
   #:use-module (gnu packages imagemagick)
   #:use-module (gnu packages ocr)
   #:use-module (gnu packages package-management)
@@ -36,11 +38,13 @@
   #:use-module (gnu packages tmux)
   #:use-module (guix gexp)
   #:use-module (guix store)
+  #:use-module (guix monads)
   #:use-module (guix packages)
   #:use-module (srfi srfi-1)
   #:export (run-basic-test
             %test-basic-os
             %test-halt
+            %test-cleanup
             %test-mcron
             %test-nss-mdns))
 
@@ -476,6 +480,67 @@ in a loop.  See <http://bugs.gnu.org/26931>.")
       (run-halt-test (virtual-machine os))))))
 

+;;;
+;;; Cleanup of /tmp, /var/run, etc.
+;;;
+
+
+(define %cleanup-os
+  (simple-operating-system
+   (simple-service 'dirty-things
+                   boot-service-type
+                   (with-monad %store-monad
+                     (let ((script (plain-file
+                                    "create-utf8-file.sh"
+                                    "exec touch /tmp/{λαμβδα,witness}")))
+                       (with-imported-modules '((guix build utils))
+                         (return #~(begin
+                                     (setenv "PATH"
+                                             #$(file-append coreutils "/bin"))
+                                     (invoke #$(file-append bash "/bin/sh")
+                                             #$script)))))))))
+
+(define (run-cleanup-test name)
+  (define os
+    (marionette-operating-system %cleanup-os
+                                 #:imported-modules '((gnu services herd)
+                                                      (guix combinators))))
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64)
+                       (ice-9 match))
+
+          (define marionette
+            (make-marionette (list #$(virtual-machine os))))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "cleanup")
+
+          (test-assert "dirty service worked"
+            (marionette-eval '(file-exists? "/witness") marionette))
+
+          (test-equal "/tmp cleaned up"
+            2
+            (marionette-eval '(stat:nlink (stat "/tmp")) marionette))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "cleanup" test))
+
+(define %test-cleanup
+  ;; See <https://bugs.gnu.org/26353>.
+  (system-test
+   (name "cleanup")
+   (description "Make sure the 'cleanup' service can remove files with
+non-ASCII names from /tmp.")
+   (value (run-cleanup-test name))))
+
+
 ;;;
 ;;; Mcron.
 ;;;
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 0cb630cfb..ac27fb5d6 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -71,6 +71,7 @@
             fdatasync
             pivot-root
             scandir*
+            with-utf8-file-names
             fcntl-flock
 
             set-thread-name
@@ -995,6 +996,35 @@ system to PUT-OLD."
       (lambda ()
         (closedir* directory)))))
 
+(define delete-file*
+  (let ((proc (syscall->procedure int "unlike" '(*))))
+    (lambda* (file #:optional (string->pointer string->pointer/utf-8))
+      (proc (string->pointer file)))))
+
+(define* (call-with-utf8-file-names thunk)
+  (let ((real-delete-file delete-file)
+        (real-opendir     opendir)
+        (real-readdir     readdir))
+    (dynamic-wind
+      (lambda ()
+        (set! delete-file delete-file*)
+        (set! opendir opendir*)
+        (set! readdir readdir*))
+      thunk
+      (lambda ()
+        (set! delete-file real-delete-file)
+        (set! opendir real-opendir)
+        (set! readdir real-readdir)))))
+
+(define-syntax-rule (with-utf8-file-names body ...)
+  "Evaluate BODY in a context where *some* of the core file system bindings
+have been replaced with variants that assume file names are UTF-8-encoded
+instead of locale-encoded.
+
+This hack is meant to address <https://bugs.gnu.org/26353>.  Use with care,
+and only in a single-threaded context!"
+  (call-with-utf8-file-names (lambda () body ...)))
+

 ;;;
 ;;; Advisory file locking.