[bug#52715] [PATCH v2 1/4] syscalls: Add 'lchown'.

[Brice Waegeneire]

* 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(+)

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