(address . guix-patches@gnu.org)
20211221193646.16849-1-brice@waegenei.re
* guix/build/syscalls.scm (lchown): New procedure.
* gnu/packages/patches/guile-3.0-linux-syscalls.patch: Add lchown.
* tests/syscalls.scm ("lchown, ENOENT", "lchown, no changes",
"lchown, regular file", "lchown, symlink"): New tests.
---
.../patches/guile-3.0-linux-syscalls.patch | 33 ++++++++++
guix/build/syscalls.scm | 16 +++++
tests/syscalls.scm | 62 +++++++++++++++++++
3 files changed, 111 insertions(+)
Toggle diff (161 lines)
diff --git a/gnu/packages/patches/guile-3.0-linux-syscalls.patch b/gnu/packages/patches/guile-3.0-linux-syscalls.patch
index 0d27f77ee2..77edd9a993 100644
--- a/gnu/packages/patches/guile-3.0-linux-syscalls.patch
+++ b/gnu/packages/patches/guile-3.0-linux-syscalls.patch
@@ -3,7 +3,40 @@ This patch adds bindings to Linux syscalls for which glibc has symbols.
Using the FFI would have been nice, but that's not an option when using
a statically-linked Guile in an initrd that doesn't have libc.so around.
+diff --git a/libguile/filesys.c b/libguile/filesys.c
+index 4f7115397..2ade4cfca 100644
+--- a/libguile/filesys.c
++++ b/libguile/filesys.c
+@@ -192,6 +192,27 @@ SCM_DEFINE (scm_chown, "chown", 3, 0, 0,
+ #undef FUNC_NAME
+ #endif /* HAVE_CHOWN */
+
++SCM_DEFINE (scm_lchown, "lchown", 3, 0, 0,
++ (SCM object, SCM owner, SCM group),
++ "As 'chown', change the ownership and group of the file referred to by\n"
++ "@var{file} to the integer values @var{owner} and @var{group} but\n"
++ "doesn't dereference symbolic links. Unlike 'chown' this doesn't support\n"
++ "port or integer file descriptor via 'fchown'.")
++#define FUNC_NAME s_scm_lchown
++{
++ int rv;
++
++ object = SCM_COERCE_OUTPORT (object);
++
++ STRING_SYSCALL (object, c_object,
++ rv = lchown (c_object,
++ scm_to_int (owner), scm_to_int (group)));
++ if (rv == -1)
++ SCM_SYSERROR;
++ return SCM_UNSPECIFIED;
++}
++#undef FUNC_NAME
++
+
+
+ SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0,
diff --git a/libguile/posix.c b/libguile/posix.c
+index a1520abc4..61d57cdb9 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -2375,6 +2375,336 @@ scm_init_popen (void)
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 45f95c509d..dbb96997d6 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -8,6 +8,7 @@
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -118,6 +119,7 @@ (define-module (guix build syscalls)
scandir*
getxattr
setxattr
+ lchown
fcntl-flock
lock-file
@@ -1277,6 +1279,20 @@ (define* (scandir* name #:optional
(lambda ()
(closedir* directory)))))
+(define-as-needed lchown
+ (let ((proc (syscall->procedure int "lchown" (list '* int int))))
+ (lambda (file owner group)
+ "As 'chown', change the ownership and group of the file referred to by
+FILE to the integer values OWNER and GROUP but doesn't dereference symbolic
+links. Unlike 'chown' this doesn't support port or integer file descriptor
+via 'fchown'."
+ (let-values (((ret err)
+ (proc (string->pointer file) owner group)))
+ (unless (zero? ret)
+ (throw 'system-error "lchown" "~S: ~A"
+ (list file (strerror err))
+ (list err)))))))
+
;;;
;;; Advisory file locking.
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index c9e011f453..24a8fd9726 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -287,6 +287,68 @@ (define perform-container-tests?
(scandir* directory)
(scandir directory (const #t) string<?))))
+(test-equal "lchown, ENOENT"
+ ENOENT
+ (catch 'system-error
+ (lambda ()
+ (lchown "/does/not/exist" 0 0))
+ (lambda args
+ (system-error-errno args))))
+
+(test-assert "lchown, no changes"
+ (call-with-temporary-directory
+ (lambda (directory)
+ (let* ((file (string-append directory "/file"))
+ (link (string-append directory "/link"))
+ (user (getpwnam (getlogin)))
+ (uid (passwd:uid user))
+ (gid (passwd:gid user)))
+ (call-with-output-file file
+ (const #t))
+ (symlink file link)
+ (lchown file -1 -1)
+ (let ((lstat (lstat link))
+ (stat (stat link)))
+ (and (eq? uid (stat:uid lstat))
+ (eq? uid (stat:uid stat))
+ (eq? gid (stat:gid lstat))
+ (eq? gid (stat:gid stat))))))))
+
+(test-assert "lchown, regular file"
+ (call-with-temporary-directory
+ (lambda (directory)
+ (let* ((file (string-append directory "/file"))
+ (nobody (getpwnam "nobody"))
+ (uid (passwd:uid nobody))
+ (gid (passwd:gid nobody)))
+ (call-with-output-file file
+ (const #t))
+ (lchown file uid gid)
+ (let ((stat (stat file)))
+ (and (eq? uid (stat:uid stat))
+ (eq? gid (stat:gid stat))))))))
+
+(test-assert "lchown, symlink"
+ (call-with-temporary-directory
+ (lambda (directory)
+ (let* ((file (string-append directory "/file"))
+ (link (string-append directory "/link"))
+ (current-user (getpwnam (getlogin)))
+ (nobody (getpwnam "nobody"))
+ (nobody-uid (passwd:uid nobody))
+ (nobody-gid (passwd:gid nobody)))
+ (call-with-output-file file
+ (const #t))
+ (symlink file link)
+ (lchown link nobody-uid nobody-gid)
+ (let ((lstat (lstat link))
+ (stat (stat link)))
+ (and (eq? nobody-uid (stat:uid lstat))
+ (eq? (passwd:uid current-user) (stat:uid stat))
+ (eq? nobody-gid (stat:gid lstat))
+ (eq? (passwd:gid current-user) (stat:gid stat))))))))
+
+
(false-if-exception (delete-file temp-file))
(test-assert "getxattr, setxattr"
(let ((key "user.translator")
--
2.34.0