This repository has no description
1open Eio.Std
2module Process = Eio_posix.Low_level.Process
3module Trace = Eio.Private.Trace
4module Fd = Eio_unix.Fd
5module Rcfd = Eio_unix.Private.Rcfd
6module Fork_action = Eio_unix.Private.Fork_action
7
8type mode = R | RW
9
10type void = {
11 args : string list;
12 env : string list;
13 cwd : string;
14 uid : int;
15 (* TODO: gid *)
16 rootfs : (string * mode) option;
17 mounts : mount list;
18}
19
20and mount = { src : string; tgt : string; mode : int [@warning "-69"] }
21
22(* Actions for namespacing *)
23module Mount = struct
24 module Flags = struct
25 include Config.Mount_flags
26
27 let empty : t = 0
28 let ( + ) = ( lor )
29 end
30
31 module Types = struct
32 type t = string
33
34 let btrfs = "btrfs"
35 let ext4 = "ext4"
36 let auto = "auto"
37 end
38end
39
40external action_mount : unit -> Fork_action.fork_fn = "void_fork_mount"
41
42let action_mount = action_mount ()
43
44let _mount ~(src : string) ~(target : string) (type_ : Mount.Types.t)
45 (flags : Mount.Flags.t) =
46 Fork_action.
47 { run = (fun k -> k (Obj.repr (action_mount, src, target, type_, flags))) }
48
49external action_pivot_root : unit -> Fork_action.fork_fn
50 = "void_fork_pivot_root"
51
52let action_pivot_root = action_pivot_root ()
53
54let pivot_root (new_root : string) (new_root_flags : Mount.Flags.t)
55 (tmpfs : bool) (mounts : mount list) =
56 Fork_action.
57 {
58 run =
59 (fun k ->
60 k
61 (Obj.repr
62 (action_pivot_root, new_root, new_root_flags, tmpfs, mounts)));
63 }
64
65external action_setuid : unit -> Fork_action.fork_fn
66 = "void_fork_setuid"
67
68let action_setuid = action_setuid ()
69
70let setuid (uid : int) = Fork_action.
71 {
72 run =
73 (fun k ->
74 k
75 (Obj.repr
76 (action_setuid, uid)));
77 }
78
79external action_map_uid_gid : unit -> Fork_action.fork_fn
80 = "void_fork_map_uid_gid"
81
82let action_map_uid_gid = action_map_uid_gid ()
83
84let map_uid_gid ~uid ~gid =
85 Fork_action.{ run = (fun k -> k (Obj.repr (action_map_uid_gid, uid, gid))) }
86
87module Flags = struct
88 include Config.Clone_flags
89
90 let ( + ) = ( lor )
91end
92
93external eio_spawn :
94 Unix.file_descr ->
95 Flags.t ->
96 Eio_unix.Private.Fork_action.c_action list ->
97 int * Unix.file_descr = "caml_void_clone3"
98
99type t = {
100 pid : int;
101 pid_fd : Fd.t;
102 exit_status : Unix.process_status Promise.t;
103}
104
105let exit_status t = t.exit_status
106let pid t = t.pid
107
108(* Read a (typically short) error message from a child process. *)
109let rec read_response fd =
110 let buf = Cstruct.create 256 in
111 match Eio_posix.Low_level.readv fd [| buf |] with
112 | 0 | (exception End_of_file) -> ""
113 | len -> Cstruct.to_string buf ~len ^ read_response fd
114
115let void_flags = List.fold_left Flags.( + ) 0 Flags.all
116
117type path = string
118
119let empty = { args = []; env = []; rootfs = None; mounts = []; cwd = "/"; uid = 0 }
120
121let actions v : Fork_action.t list =
122 let root, tmpfs, root_mode =
123 match v.rootfs with
124 | None -> (Filename.temp_dir "void-" "-tmpdir", true, R)
125 | Some (s, m) -> (s, false, m)
126 in
127 let args = match v.args with [] -> failwith "No exec" | args -> args in
128 let e =
129 Process.Fork_action.execve (List.hd args) ~env:(Array.of_list v.env)
130 ~argv:(Array.of_list args)
131 in
132 (* Process mount point points *)
133 let mounts =
134 List.map
135 (fun mnt ->
136 let src = Filename.concat "/.old_root" mnt.src in
137 let tgt = Filename.concat "/" mnt.tgt in
138 { mnt with tgt; src })
139 v.mounts
140 in
141 let root_flags =
142 if root_mode = R then Mount.Flags.ms_rdonly else Mount.Flags.empty
143 in
144 let mounts = pivot_root root root_flags tmpfs mounts in
145 let uid, gid = Unix.(getuid (), getgid ()) in
146 let user_namespace = map_uid_gid ~uid ~gid in
147 [ user_namespace; mounts; setuid v.uid; Process.Fork_action.chdir v.cwd; e ]
148
149let rootfs ~mode path v = { v with rootfs = Some (path, mode) }
150let cwd cwd v = { v with cwd }
151let uid uid v = { v with uid }
152let exec ?(env=[]) args v = { v with args; env }
153
154let mount ~mode ~src ~tgt v =
155 let mode = if mode = R then Mount.Flags.ms_rdonly else Mount.Flags.empty in
156 { v with mounts = { src; tgt; mode } :: v.mounts }
157
158(* From eio_linux/eio_posix *)
159let with_pipe fn =
160 Switch.run @@ fun sw ->
161 let r, w = Eio_posix.Low_level.pipe ~sw in
162 fn r w
163
164external pidfd_send_signal : Unix.file_descr -> int -> unit
165 = "caml_void_pidfd_send_signal"
166
167let signal t signum =
168 Fd.use t.pid_fd ~if_closed:Fun.id @@ fun pid_fd ->
169 pidfd_send_signal pid_fd signum
170
171let rec waitpid pid =
172 match Unix.waitpid [] pid with
173 | p, status ->
174 assert (p = pid);
175 status
176 | exception Unix.Unix_error (EINTR, _, _) -> waitpid pid
177
178let spawn ~sw v =
179 with_pipe @@ fun errors_r errors_w ->
180 Eio_unix.Private.Fork_action.with_actions (actions v) @@ fun c_actions ->
181 Switch.check sw;
182 let exit_status, set_exit_status = Promise.create () in
183 let t =
184 let pid, pid_fd =
185 Fd.use_exn "errors-w" errors_w @@ fun errors_w ->
186 Eio.Private.Trace.with_span "spawn" @@ fun () ->
187 let flags = Flags.(clone_pidfd + void_flags) in
188 eio_spawn errors_w flags c_actions
189 in
190 let pid_fd = Fd.of_unix ~sw ~seekable:false ~close_unix:true pid_fd in
191 { pid; pid_fd; exit_status }
192 in
193 Fd.close errors_w;
194 Fiber.fork_daemon ~sw (fun () ->
195 let cleanup () =
196 Fd.close t.pid_fd;
197 Promise.resolve set_exit_status (waitpid t.pid);
198 `Stop_daemon
199 in
200 match Eio_posix.Low_level.await_readable "void_spawn" t.pid_fd with
201 | () -> Eio.Cancel.protect cleanup
202 | exception Eio.Cancel.Cancelled _ ->
203 Eio.Cancel.protect (fun () ->
204 Printf.eprintf "Cancelled?";
205 signal t Sys.sigkill;
206 Eio_posix.Low_level.await_readable "void_spawn" t.pid_fd;
207 cleanup ()));
208 (* Check for errors starting the process. *)
209 match read_response errors_r with
210 | "" -> t (* Success! Execing the child closed [errors_w] and we got EOF. *)
211 | err -> failwith err
212
213let to_eio_status t =
214 match t with
215 | Unix.WEXITED i -> `Exited i
216 | Unix.WSIGNALED i -> `Signaled i
217 | Unix.WSTOPPED _ -> assert false
218
219let exit_status_to_string = function
220 | Unix.WEXITED n -> Printf.sprintf "Exited with %i" n
221 | Unix.WSTOPPED n -> Printf.sprintf "Stopped with %i" n
222 | Unix.WSIGNALED n -> Printf.sprintf "Signalled with %i" n