Package: guix;
Reported by: Danny Milosavljevic <dannym <at> scratchpost.org>
Date: Mon, 3 Apr 2017 18:57:02 UTC
Severity: important
Tags: patch
Done: ludo <at> gnu.org (Ludovic Courtès)
Bug is archived. No further changes may be made.
Message #60 received at 26353 <at> debbugs.gnu.org (full text, mbox):
From: ludo <at> gnu.org (Ludovic Courtès) To: Danny Milosavljevic <dannym <at> scratchpost.org> Cc: 26353 <at> debbugs.gnu.org Subject: Re: bug#26353: GuixSD /tmp cleaner fails to clean when Umlauts like "ä" are used in filenames Date: Fri, 15 Dec 2017 11:27:49 +0100
[Message part 1 (text/plain, inline)]
Danny Milosavljevic <dannym <at> scratchpost.org> 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’.
[Message part 2 (text/x-patch, inline)]
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.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.