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

Message received at submit <at> debbugs.gnu.org:

Received: (at submit) by debbugs.gnu.org; 21 Dec 2021 19:37:22 +0000
From debbugs-submit-bounces <at> debbugs.gnu.org Tue Dec 21 14:37:22 2021
Received: from localhost ([127.0.0.1]:55704 helo=debbugs.gnu.org)
	by debbugs.gnu.org with esmtp (Exim 4.84_2)
	(envelope-from <debbugs-submit-bounces <at> debbugs.gnu.org>)
	id 1mzkwd-00078d-Dd
	for submit <at> debbugs.gnu.org; Tue, 21 Dec 2021 14:37:22 -0500
Received: from lists.gnu.org ([209.51.188.17]:37572)
 by debbugs.gnu.org with esmtp (Exim 4.84_2)
 (envelope-from <brice@HIDDEN>) id 1mzkwT-000778-8A
 for submit <at> debbugs.gnu.org; Tue, 21 Dec 2021 14:36:59 -0500
Received: from eggs.gnu.org ([209.51.188.92]:36174)
 by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)
 (Exim 4.90_1) (envelope-from <brice@HIDDEN>) id 1mzkwT-0001y9-1V
 for guix-patches@HIDDEN; Tue, 21 Dec 2021 14:36:57 -0500
Received: from relay12.mail.gandi.net ([217.70.178.232]:57037)
 by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256)
 (Exim 4.90_1) (envelope-from <brice@HIDDEN>) id 1mzkwP-0004Ej-8L
 for guix-patches@HIDDEN; Tue, 21 Dec 2021 14:36:56 -0500
Received: (Authenticated sender: brice@HIDDEN)
 by relay12.mail.gandi.net (Postfix) with ESMTPSA id C7D1F200004
 for <guix-patches@HIDDEN>; Tue, 21 Dec 2021 19:36:49 +0000 (UTC)
From: Brice Waegeneire <brice@HIDDEN>
To: guix-patches@HIDDEN
Subject: [PATCH v2 1/4] syscalls: Add 'lchown'.
Date: Tue, 21 Dec 2021 20:36:43 +0100
Message-Id: <20211221193646.16849-1-brice@HIDDEN>
X-Mailer: git-send-email 2.34.0
In-Reply-To: <8735mleoxo.fsf_-_@HIDDEN>
References: <8735mleoxo.fsf_-_@HIDDEN>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Received-SPF: pass client-ip=217.70.178.232; envelope-from=brice@HIDDEN;
 helo=relay12.mail.gandi.net
X-Spam_score_int: -25
X-Spam_score: -2.6
X-Spam_bar: --
X-Spam_report: (-2.6 / 5.0 requ) BAYES_00=-1.9, RCVD_IN_DNSWL_LOW=-0.7,
 RCVD_IN_MSPIKE_H2=-0.001, SPF_HELO_NONE=0.001,
 SPF_PASS=-0.001 autolearn=ham autolearn_force=no
X-Spam_action: no action
X-Spam-Score: 0.0 (/)
X-Debbugs-Envelope-To: submit
X-BeenThere: debbugs-submit <at> debbugs.gnu.org
X-Mailman-Version: 2.1.18
Precedence: list
List-Id: <debbugs-submit.debbugs.gnu.org>
List-Unsubscribe: <https://debbugs.gnu.org/cgi-bin/mailman/options/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=unsubscribe>
List-Archive: <https://debbugs.gnu.org/cgi-bin/mailman/private/debbugs-submit/>
List-Post: <mailto:debbugs-submit <at> debbugs.gnu.org>
List-Help: <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=help>
List-Subscribe: <https://debbugs.gnu.org/cgi-bin/mailman/listinfo/debbugs-submit>, 
 <mailto:debbugs-submit-request <at> debbugs.gnu.org?subject=subscribe>
Errors-To: debbugs-submit-bounces <at> debbugs.gnu.org
Sender: "Debbugs-submit" <debbugs-submit-bounces <at> debbugs.gnu.org>
X-Spam-Score: -1.0 (-)

* 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@HIDDEN>
 ;;; Copyright © 2021 Chris Marusich <cmmarusich@HIDDEN>
 ;;; Copyright © 2021 Tobias Geerinckx-Rice <me@HIDDEN>
+;;; Copyright © 2021 Brice Waegeneire <brice@HIDDEN>
 ;;;
 ;;; 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