Add setuid fork action

Author: patricoferris

lib_eio/process.ml

@@ -71,6 +71,7 @@ module Pi = struct
     val spawn :
       t ->
       sw:Switch.t ->
+      ?uid:int ->
       ?cwd:Fs.dir_ty Path.t ->
       ?stdin:Flow.source_ty r ->
       ?stdout:Flow.sink_ty r ->
@@ -121,20 +122,21 @@ let signal (type tag) (t : [> tag ty] r) s =
   let module X = (val (Resource.get ops Pi.Process)) in
   X.signal v s
 
-let spawn (type tag) ~sw (t : [> tag mgr_ty] r) ?cwd ?stdin ?stdout ?stderr ?env ?executable args : tag ty r =
+let spawn (type tag) ~sw (t : [> tag mgr_ty] r) ?uid ?cwd ?stdin ?stdout ?stderr ?env ?executable args : tag ty r =
   let (Resource.T (v, ops)) = t in
   let module X = (val (Resource.get ops Pi.Mgr)) in
   X.spawn v ~sw
+    ?uid
     ?cwd:(cwd :> Fs.dir_ty Path.t option)
     ?env
     ?executable args
     ?stdin:(stdin :> Flow.source_ty r option)
     ?stdout:(stdout :> Flow.sink_ty r option)
     ?stderr:(stderr :> Flow.sink_ty r option)
 
-let run t ?cwd ?stdin ?stdout ?stderr ?(is_success = Int.equal 0) ?env ?executable args =
+let run t ?uid ?cwd ?stdin ?stdout ?stderr ?(is_success = Int.equal 0) ?env ?executable args =
   Switch.run ~name:"Process.run" @@ fun sw ->
-  let child = spawn ~sw t ?cwd ?stdin ?stdout ?stderr ?env ?executable args in
+  let child = spawn ~sw t ?uid ?cwd ?stdin ?stdout ?stderr ?env ?executable args in
   match await child with
   | `Exited code when is_success code -> ()
   | status ->
@@ -145,11 +147,11 @@ let pipe (type tag) ~sw ((Resource.T (v, ops)) : [> tag mgr_ty] r) =
   let module X = (val (Resource.get ops Pi.Mgr)) in
   X.pipe v ~sw
 
-let parse_out (type tag) (t : [> tag mgr_ty] r) parse ?cwd ?stdin ?stderr ?is_success ?env ?executable args =
+let parse_out (type tag) (t : [> tag mgr_ty] r) parse ?uid ?cwd ?stdin ?stderr ?is_success ?env ?executable args =
   Switch.run ~name:"Process.parse_out" @@ fun sw ->
   let r, w = pipe t ~sw in
   try
-    let child = spawn ~sw t ?cwd ?stdin ~stdout:w ?stderr ?env ?executable args in
+    let child = spawn ~sw t ?uid ?cwd ?stdin ~stdout:w ?stderr ?env ?executable args in
     Flow.close w;
     let output = Buf_read.parse_exn parse r ~max_size:max_int in
     Flow.close r;

lib_eio/process.mli

@@ -75,6 +75,7 @@ val signal : _ t -> int -> unit
 val spawn :
   sw:Switch.t ->
   [> 'tag mgr_ty] r ->
+  ?uid:int ->
   ?cwd:Fs.dir_ty Path.t ->
   ?stdin:_ Flow.source ->
   ?stdout:_ Flow.sink ->
@@ -90,6 +91,7 @@ val spawn :
     this also creates pipes and spawns fibers to copy the data as necessary.
     If you need more control over file descriptors, see {!Eio_unix.Process}.
 
+    @param uid The uid for the child process (default: same as parent process).
     @param cwd The current working directory of the process (default: same as parent process).
     @param stdin The flow to attach to the process's standard input (default: same as parent process).
     @param stdout A flow that the process's standard output goes to (default: same as parent process).
@@ -101,6 +103,7 @@ val spawn :
 
 val run :
   _ mgr ->
+  ?uid:int ->
   ?cwd:_ Path.t ->
   ?stdin:_ Flow.source ->
   ?stdout:_ Flow.sink ->
@@ -120,6 +123,7 @@ val run :
 val parse_out :
   _ mgr ->
   'a Buf_read.parser ->
+  ?uid:int ->
   ?cwd:_ Path.t ->
   ?stdin:_ Flow.source ->
   ?stderr:_ Flow.sink ->
@@ -176,6 +180,7 @@ module Pi : sig
     val spawn :
       t ->
       sw:Switch.t ->
+      ?uid:int ->
       ?cwd:Fs.dir_ty Path.t ->
       ?stdin:Flow.source_ty r ->
       ?stdout:Flow.sink_ty r ->

lib_eio/unix/fork_action.c

@@ -237,3 +237,21 @@ static void action_dups(int errors, value v_config) {
 CAMLprim value eio_unix_fork_dups(value v_unit) {
   return Val_fork_fn(action_dups);
 }
+
+static void action_setuid(int errors, value v_config) {
+  #ifdef _WIN32
+  eio_unix_fork_error(errors, "action_setuid", "Unsupported operation on windows");
+  #else
+  value v_uid = Field(v_config, 1);
+  int r;
+  r = setuid(Int_val(v_uid));
+  if (r != 0) {
+    eio_unix_fork_error(errors, "setuid", strerror(errno));
+    _exit(1);
+  }
+  #endif
+}
+
+CAMLprim value eio_unix_fork_setuid(value v_unit) {
+  return Val_fork_fn(action_setuid);
+}

lib_eio/unix/fork_action.ml

@@ -68,3 +68,8 @@ let inherit_fds m =
   with_fds m @@ fun m ->
   let plan : action list = Inherit_fds.plan m in
   { run = fun k -> k (Obj.repr (action_dups, plan, blocking)) }
+
+external action_setuid : unit -> fork_fn = "eio_unix_fork_setuid"
+let action_setuid = action_setuid ()
+let setuid uid = {
+  run = fun k -> k (Obj.repr (action_setuid, uid)) }

lib_eio/unix/fork_action.mli

@@ -44,6 +44,9 @@ val chdir : string -> t
 val fchdir : Fd.t -> t
 (** [fchdir fd] changes directory to [fd]. *)
 
+val setuid : int -> t
+(** [setuid uid] sets the user ID to [uid]. *)
+
 type blocking = [
   | `Blocking            (** Clear the [O_NONBLOCK] flag in the child process. *)
   | `Nonblocking         (** Set the [O_NONBLOCK] flag in the child process. *)

lib_eio/unix/process.ml

@@ -82,6 +82,7 @@ module Pi = struct
     val spawn_unix :
       t ->
       sw:Switch.t ->
+      ?uid:int ->
       ?cwd:Eio.Fs.dir_ty Eio.Path.t ->
       env:string array ->
       fds:(int * Fd.t * Fork_action.blocking) list ->
@@ -106,6 +107,7 @@ module Make_mgr (X : sig
   val spawn_unix :
     t ->
     sw:Switch.t ->
+    ?uid:int ->
     ?cwd:Eio.Fs.dir_ty Eio.Path.t ->
     env:string array ->
     fds:(int * Fd.t * Fork_action.blocking) list ->
@@ -121,7 +123,7 @@ end) = struct
     (Private.pipe sw :> ([Eio.Resource.close_ty | Eio.Flow.source_ty] r *
     [Eio.Resource.close_ty | Eio.Flow.sink_ty] r))
 
-  let spawn v ~sw ?cwd ?stdin ?stdout ?stderr ?env ?executable args =
+  let spawn v ~sw ?uid ?cwd ?stdin ?stdout ?stderr ?env ?executable args =
     let executable = get_executable executable ~args in
     let env = get_env env in
     with_close_list @@ fun to_close ->
@@ -133,16 +135,16 @@ end) = struct
       1, stdout_fd, `Blocking;
       2, stderr_fd, `Blocking;
     ] in
-    X.spawn_unix v ~sw ?cwd ~env ~fds ~executable args
+    X.spawn_unix v ~sw ?uid ?cwd ~env ~fds ~executable args
 
   let spawn_unix = X.spawn_unix
 end
 
-let spawn_unix ~sw (Eio.Resource.T (v, ops)) ?cwd ~fds ?env ?executable args =
+let spawn_unix ~sw (Eio.Resource.T (v, ops)) ?uid ?cwd ~fds ?env ?executable args =
   let module X = (val (Eio.Resource.get ops Pi.Mgr_unix)) in
   let executable = get_executable executable ~args in
   let env = get_env env in
-  X.spawn_unix v ~sw ?cwd ~fds ~env ~executable args
+  X.spawn_unix v ~sw ?uid ?cwd ~fds ~env ~executable args
 
 let sigchld = Eio.Condition.create ()
 

lib_eio/unix/process.mli

@@ -19,6 +19,7 @@ module Pi : sig
     val spawn_unix :
       t ->
       sw:Switch.t ->
+      ?uid:int ->
       ?cwd:Eio.Fs.dir_ty Eio.Path.t ->
       env:string array ->
       fds:(int * Fd.t * Fork_action.blocking) list ->
@@ -41,6 +42,7 @@ module Make_mgr (X : sig
   val spawn_unix :
     t ->
     sw:Switch.t ->
+    ?uid:int ->
     ?cwd:Eio.Fs.dir_ty Eio.Path.t ->
     env:string array ->
     fds:(int * Fd.t * Fork_action.blocking) list ->
@@ -52,6 +54,7 @@ end) : Pi.MGR with type t = X.t and type tag = [`Generic | `Unix]
 val spawn_unix :
     sw:Switch.t ->
     _ mgr ->
+    ?uid:int ->
     ?cwd:Eio.Fs.dir_ty Eio.Path.t ->
     fds:(int * Fd.t * Fork_action.blocking) list ->
     ?env:string array ->

lib_eio_linux/eio_linux.ml

@@ -219,11 +219,15 @@ module Process_mgr = struct
   module T = struct
     type t = unit 
 
-    let spawn_unix () ~sw ?cwd ~env ~fds ~executable args =
+    let spawn_unix () ~sw ?uid ?cwd ~env ~fds ~executable args =
       let actions = Low_level.Process.Fork_action.[
           Eio_unix.Private.Fork_action.inherit_fds fds;
           execve executable ~argv:(Array.of_list args) ~env
       ] in
+      let actions = match uid with
+        | None -> actions
+        | Some uid -> Eio_unix.Private.Fork_action.setuid uid :: actions
+      in
       let with_actions cwd fn = match cwd with
         | None -> fn actions
         | Some (fd, s) ->

lib_eio_posix/process.ml

@@ -23,11 +23,15 @@ module Impl = struct
   module T = struct
     type t = unit
 
-    let spawn_unix () ~sw ?cwd ~env ~fds ~executable args =
+    let spawn_unix () ~sw ?uid ?cwd ~env ~fds ~executable args =
       let actions = Low_level.Process.Fork_action.[
           inherit_fds fds;
           execve executable ~argv:(Array.of_list args) ~env
       ] in
+      let actions = match uid with
+        | None -> actions
+        | Some uid -> Eio_unix.Private.Fork_action.setuid uid :: actions
+      in
       let with_actions cwd fn = match cwd with
         | None -> fn actions
         | Some ((dir, path) : Eio.Fs.dir_ty Eio.Path.t) ->