daemon: Reimplement guestfs_selinux_relabel in OCaml

No change, just reimplement the existing C implementation in OCaml.

.gitignore

@@ -108,6 +108,7 @@ Makefile.in
 /daemon/parted.mli
 /daemon/realpath.mli
 /daemon/rpm.mli
+/daemon/selinux.mli
 /daemon/sfdisk.mli
 /daemon/stamp-guestfsd.pod
 /daemon/statvfs.mli

daemon/Makefile.am

@@ -59,6 +59,7 @@ generator_built = \
 	parted.mli \
 	realpath.mli \
 	rpm.mli \
+	selinux.mli \
 	sfdisk.mli \
 	statvfs.mli \
 	structs.ml \
@@ -173,7 +174,6 @@ guestfsd_SOURCES = \
 	rsync.c \
 	scrub.c \
 	selinux.c \
-	selinux-relabel.c \
 	sfdisk.c \
 	sh.c \
 	sleep.c \
@@ -307,6 +307,7 @@ SOURCES_MLI = \
 	parted.mli \
 	realpath.mli \
 	rpm.mli \
+	selinux.mli \
 	sfdisk.mli \
 	statvfs.mli \
 	structs.mli \
@@ -345,6 +346,7 @@ SOURCES_ML = \
 	listfs.ml \
 	realpath.ml \
 	statvfs.ml \
+	selinux.ml \
 	inspect_types.ml \
 	inspect_utils.ml \
 	inspect_fs_unix_fstab.ml \

daemon/selinux-relabel.c

@@ -1,169 +0,0 @@
-/* libguestfs - the guestfsd daemon
- * Copyright (C) 2016 Red Hat Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this program; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
- */
-
-#include <config.h>
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <sys/stat.h>
-
-#include "guestfs_protocol.h"
-#include "daemon.h"
-#include "actions.h"
-#include "optgroups.h"
-
-#include "ignore-value.h"
-
-#define MAX_ARGS 64
-
-int
-optgroup_selinuxrelabel_available (void)
-{
-  return prog_exists ("setfiles");
-}
-
-static int
-dir_exists (const char *dir)
-{
-  struct stat statbuf;
-
-  if (stat (dir, &statbuf) == 0 && S_ISDIR (statbuf.st_mode))
-    return 1;
-  else
-    return 0;
-}
-
-static int
-setfiles_has_option (int *flag, char opt_char)
-{
-  CLEANUP_FREE char *err = NULL;
-
-  if (*flag == -1) {
-    char option[] = { '-', opt_char, '\0' };       /* "-X" */
-    char err_opt[32];     /* "invalid option -- 'X'" */
-
-    snprintf(err_opt, sizeof(err_opt), "invalid option -- '%c'", opt_char);
-    ignore_value (command (NULL, &err, "setfiles", option, NULL));
-    *flag = err && strstr (err, /* "invalid option -- " */ err_opt) == NULL;
-  }
-
-  return *flag;
-}
-
-/* Takes optional arguments, consult optargs_bitmask. */
-int
-do_selinux_relabel (const char *specfile, const char *path,
-                    int force)
-{
-  static int flag_m = -1;
-  static int flag_C = -1;
-  static int flag_T = -1;
-  const char *argv[MAX_ARGS];
-  CLEANUP_FREE char *s_dev = NULL, *s_proc = NULL, *s_selinux = NULL,
-    *s_sys = NULL, *s_specfile = NULL, *s_path = NULL;
-  CLEANUP_FREE char *err = NULL;
-  size_t i = 0;
-  int setfiles_status;
-
-  s_dev = sysroot_path ("/dev");
-  if (!s_dev) {
-  malloc_error:
-    reply_with_perror ("malloc");
-    return -1;
-  }
-  s_proc = sysroot_path ("/proc");       if (!s_proc) goto malloc_error;
-  s_selinux = sysroot_path ("/selinux"); if (!s_selinux) goto malloc_error;
-  s_sys = sysroot_path ("/sys");         if (!s_sys) goto malloc_error;
-  s_specfile = sysroot_path (specfile);  if (!s_specfile) goto malloc_error;
-  s_path = sysroot_path (path);          if (!s_path) goto malloc_error;
-
-  /* Default settings if not selected. */
-  if (!(optargs_bitmask & GUESTFS_SELINUX_RELABEL_FORCE_BITMASK))
-    force = 0;
-
-  /* If setfiles takes an excessively long time to run (but still
-   * completes) then removing .../contexts/files/file_contexts.bin
-   * appears to help.  If you find any such cases, please add
-   * observations to the bug report:
-   * https://bugzilla.redhat.com/show_bug.cgi?id=1396297
-   */
-  ADD_ARG (argv, i, "setfiles");
-  if (force)
-    ADD_ARG (argv, i, "-F");
-
-  /* Exclude some directories that should never be relabelled in
-   * ordinary Linux guests.  These won't be mounted anyway.  We have
-   * to prefix all these with the sysroot path.
-   */
-  ADD_ARG (argv, i, "-e"); ADD_ARG (argv, i, s_dev);
-  ADD_ARG (argv, i, "-e"); ADD_ARG (argv, i, s_proc);
-  ADD_ARG (argv, i, "-e"); ADD_ARG (argv, i, s_sys);
-  if (dir_exists (s_selinux)) {
-    ADD_ARG (argv, i, "-e"); ADD_ARG (argv, i, s_selinux);
-  }
-
-  /* You have to use the -m option (where available) otherwise
-   * setfiles puts all the mountpoints on the excludes list for no
-   * useful reason (RHBZ#1433577).
-   */
-  if (setfiles_has_option (&flag_m, 'm'))
-    ADD_ARG (argv, i, "-m");
-
-  /* Not only do we want setfiles to trudge through individual relabeling
-   * errors, we also want the setfiles exit status to differentiate a fatal
-   * error from "relabeling errors only". See RHBZ#1794518.
-   */
-  if (setfiles_has_option (&flag_C, 'C'))
-    ADD_ARG (argv, i, "-C");
-
-  /* If the appliance is being run with multiple vCPUs, running setfiles
-   * in multithreading mode might speeds up the process.  Option "-T" was
-   * introduced in SELinux userspace v3.4, and we need to check whether it's
-   * supported.  Passing "-T 0" creates as many threads as there're available
-   * vCPU cores.
-   * https://github.com/SELinuxProject/selinux/releases/tag/3.4
-   */
-  if (setfiles_has_option (&flag_T, 'T')) {
-    ADD_ARG (argv, i, "-T"); ADD_ARG (argv, i, "0");
-  }
-
-  /* Relabelling in a chroot. */
-  if (STRNEQ (sysroot, "/")) {
-    ADD_ARG (argv, i, "-r");
-    ADD_ARG (argv, i, sysroot);
-  }
-
-  if (verbose)
-    ADD_ARG (argv, i, "-v");
-  else
-    /* Suppress non-error output. */
-    ADD_ARG (argv, i, "-q");
-
-  /* Add parameters. */
-  ADD_ARG (argv, i, s_specfile);
-  ADD_ARG (argv, i, s_path);
-  ADD_ARG (argv, i, NULL);
-
-  setfiles_status = commandrv (NULL, &err, argv);
-  if ((setfiles_status == 0) || (setfiles_status == 1 && flag_C))
-    return 0;
-
-  reply_with_error ("%s", err);
-  return -1;
-}

daemon/selinux.c

@@ -39,6 +39,13 @@ optgroup_selinux_available (void)
   return 1;
 }
 
+/* For historical reasons, this is really "is setfiles available" */
+int
+optgroup_selinuxrelabel_available (void)
+{
+  return prog_exists ("setfiles");
+}
+
 /* setcon is only valid under the following circumstances:
  * - single threaded
  * - enforcing=0

daemon/selinux.ml

@@ -0,0 +1,101 @@
+(* SELinux functions.
+ * Copyright (C) 2009-2025 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Printf
+
+open Std_utils
+
+open Sysroot
+open Utils
+
+(* Test if setfiles has various options.
+ *
+ * The only way to do this is to run setfiles with the option alone, and
+ * test for the stderr message [invalid option -- 'X'].
+ *)
+let setfiles_has_option_m,
+    setfiles_has_option_C,
+    setfiles_has_option_T =
+  let setfiles_has_option flag =
+    let err_msg = sprintf "invalid option -- '%c'" flag in
+    let opt = sprintf "-%c" flag in
+    let _, _, err = commandr "setfiles" [opt] in
+    String.find err err_msg = -1
+  in
+  let setfiles_has_option_m = lazy (setfiles_has_option 'm')
+  and setfiles_has_option_C = lazy (setfiles_has_option 'C')
+  and setfiles_has_option_T = lazy (setfiles_has_option 'T') in
+  (fun () -> Lazy.force setfiles_has_option_m),
+  (fun () -> Lazy.force setfiles_has_option_C),
+  (fun () -> Lazy.force setfiles_has_option_T)
+
+let selinux_relabel ?(force = false) specfile path =
+  (* Prefix /sysroot on all paths. *)
+  let ignored_paths =
+    [ "/dev"; "/proc"; "/selinux"; "/sys" ] |>
+    List.map sysroot_path in
+  let specfile = sysroot_path specfile in
+  let path = sysroot_path path in
+
+  let args = ref [] in
+  if force then List.push_back args "-F";
+  List.iter (
+    fun ignored_path ->
+      List.push_back_list args [ "-e"; ignored_path ]
+  ) ignored_paths;
+
+  (* You have to use the -m option (where available) otherwise
+   * setfiles puts all the mountpoints on the excludes list for no
+   * useful reason (RHBZ#1433577).
+   *)
+  if setfiles_has_option_m () then List.push_back args "-m";
+
+  (* Not only do we want setfiles to trudge through individual relabeling
+   * errors, we also want the setfiles exit status to differentiate a fatal
+   * error from "relabeling errors only". See RHBZ#1794518.
+   *)
+  if setfiles_has_option_C () then List.push_back args "-C";
+
+  (* If the appliance is being run with multiple vCPUs, running setfiles
+   * in multithreading mode might speeds up the process.  Option "-T" was
+   * introduced in SELinux userspace v3.4, and we need to check whether it's
+   * supported.  Passing "-T 0" creates as many threads as there're available
+   * vCPU cores.
+   * https://github.com/SELinuxProject/selinux/releases/tag/3.4
+   *)
+  if setfiles_has_option_T () then
+    List.push_back_list args [ "-T"; "0" ];
+
+  (* Relabelling in a chroot. *)
+  if sysroot () <> "/" then
+    List.push_back_list args [ "-r"; sysroot () ];
+
+  if verbose () then
+    List.push_back args "-v"
+  else
+    (* Suppress non-error output. *)
+    List.push_back args "-q";
+
+  (* Add parameters. *)
+  List.push_back_list args [ specfile; path ];
+
+  let args = !args in
+  let r, _, err = commandr "setfiles" args in
+
+  let ok = r = 0 || r = 1 && setfiles_has_option_C () in
+  if not ok then failwithf "setfiles: %s" err

docs/C_SOURCE_FILES

@@ -132,7 +132,6 @@ daemon/rename.c
 daemon/rpm-c.c
 daemon/rsync.c
 daemon/scrub.c
-daemon/selinux-relabel.c
 daemon/selinux.c
 daemon/sfdisk.c
 daemon/sh.c

generator/actions_core.ml

@@ -9359,6 +9359,7 @@ fails and the C<errno> is set to C<ENODEV>." };
   { defaults with
     name = "selinux_relabel"; added = (1, 33, 43);
     style = RErr, [String (PlainString, "specfile"); String (Pathname, "path")], [OBool "force"];
+    impl = OCaml "Selinux.selinux_relabel";
     optional = Some "selinuxrelabel";
     test_excuse = "tests are in the tests/relabel directory";
     shortdesc = "relabel parts of the filesystem";

po/POTFILES

@@ -110,7 +110,6 @@ daemon/rename.c
 daemon/rpm-c.c
 daemon/rsync.c
 daemon/scrub.c
-daemon/selinux-relabel.c
 daemon/selinux.c
 daemon/sfdisk.c
 daemon/sh.c