this repo has no description
patrick.sirref.org
1open Eio_posix
2open Eio.Std
3
4type (_, _, _) Eio.Resource.pi +=
5 | Posix_dir : ('t, 't -> Low_level.dir_fd, [> `Posix_dir ]) Eio.Resource.pi
6
7let as_posix_dir (Eio.Resource.T (t, ops)) =
8 match Eio.Resource.get_opt ops Posix_dir with
9 | None -> None
10 | Some fn -> Some (fn t)
11
12module Process_impl = struct
13 type t = Low_level.Process.t
14 type tag = [ `Generic | `Unix ]
15
16 let pid = Low_level.Process.pid
17
18 let await t =
19 match Eio.Promise.await @@ Low_level.Process.exit_status t with
20 | Unix.WEXITED i -> `Exited i
21 | Unix.WSIGNALED i -> `Signaled i
22 | Unix.WSTOPPED _ -> assert false
23
24 let signal = Low_level.Process.signal
25end
26
27let process =
28 let handler = Eio.Process.Pi.process (module Process_impl) in
29 fun proc -> Eio.Resource.T (proc, handler)
30
31module T = struct
32 type t = unit
33
34 external action_setuid : unit -> Eio_unix.Private.Fork_action.fork_fn
35 = "eio_unix_fork_setuid"
36
37 let action_setuid = action_setuid ()
38
39 let setuid (uid : int) =
40 Eio_unix.Private.Fork_action.
41 { run = (fun k -> k (Obj.repr (action_setuid, uid))) }
42
43 external action_setcgroup : unit -> Eio_unix.Private.Fork_action.fork_fn
44 = "eio_unix_fork_setcgroup"
45
46 let action_setcgroup = action_setcgroup ()
47
48 let setcgroup group =
49 Eio_unix.Private.Fork_action.
50 { run = (fun k -> k (Obj.repr (action_setcgroup, group))) }
51
52 let spawn_unix () ~group ~uid ~sw ?cwd ~env ~fds ~executable args =
53 let actions =
54 Low_level.Process.Fork_action.
55 [ inherit_fds fds; execve executable ~argv:(Array.of_list args) ~env ]
56 in
57 let actions =
58 match uid with None -> actions | Some uid -> setuid uid :: actions
59 in
60 let actions =
61 match group with None -> actions | Some g -> setcgroup g :: actions
62 in
63 let with_actions cwd fn =
64 match cwd with
65 | None -> fn actions
66 | Some ((dir, path) : Eio.Fs.dir_ty Eio.Path.t) -> (
67 match as_posix_dir dir with
68 | None -> Fmt.invalid_arg "cwd is not an OS directory!"
69 | Some dirfd ->
70 Switch.run ~name:"spawn_unix" @@ fun launch_sw ->
71 let cwd =
72 Low_level.openat ~sw:launch_sw ~mode:0 dirfd path
73 Low_level.Open_flags.(rdonly + directory)
74 in
75 fn (Low_level.Process.Fork_action.fchdir cwd :: actions))
76 in
77 with_actions cwd @@ fun actions ->
78 process (Low_level.Process.spawn ~sw actions)
79end
80
81let make_process group uid =
82 let module T = struct
83 type t = unit
84
85 let spawn_unix = T.spawn_unix ~group ~uid
86 end in
87 let h = Eio_unix.Process.Pi.mgr_unix (module Eio_unix.Process.Make_mgr (T)) in
88 Eio.Resource.T ((), h)