Source file fork_action.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
type c_action = Obj.t

type t = { run : 'a. ((c_action -> 'a) -> 'a) } [@@unboxed]

(* A [fork_fn] is a C function that can be executed after forking. It cannot call OCaml code or
   run the OCaml GC. It is passed a [Unix.file_descr] for errors and a pointer
   to a [c_action]. On success it should write nothing to the error stream and
   return 0. On error, it should write a message to the error FD and return a
   non-zero value for the exit status (e.g. 1). *)
type fork_fn

let rec with_actions actions fn =
  match actions with
  | [] -> fn []
  | { run } :: xs ->
    run @@ fun c_action ->
    with_actions xs @@ fun c_actions ->
    fn (c_action :: c_actions)

type c_array
external make_string_array : int -> c_array = "eio_unix_make_string_array"
external action_execve : unit -> fork_fn = "eio_unix_fork_execve"
let action_execve = action_execve ()
let execve path ~argv ~env =
  let argv_c_array = make_string_array (Array.length argv) in
  let env_c_array = make_string_array (Array.length env) in
  { run = fun k -> k (Obj.repr (action_execve, path, argv_c_array, argv, env_c_array, env)) }

external action_chdir : unit -> fork_fn = "eio_unix_fork_chdir"
let action_chdir = action_chdir ()
let chdir path = { run = fun k -> k (Obj.repr (action_chdir, path)) }

external action_fchdir : unit -> fork_fn = "eio_unix_fork_fchdir"
let action_fchdir = action_fchdir ()
let fchdir fd = {
  run = fun k ->
    Fd.use_exn "fchdir" fd @@ fun fd ->
    k (Obj.repr (action_fchdir, fd)) }

let int_of_fd : Unix.file_descr -> int = Obj.magic

type action = Inherit_fds.action = { src : int; dst : int }

let rec with_fds mapping k =
  match mapping with
  | [] -> k []
  | (dst, src, _) :: xs ->
    Fd.use_exn "inherit_fds" src @@ fun src ->
    with_fds xs @@ fun xs ->
    k ((dst, int_of_fd src) :: xs)

type blocking = [
  | `Blocking
  | `Nonblocking
  | `Preserve_blocking
]

external action_dups : unit -> fork_fn = "eio_unix_fork_dups"
let action_dups = action_dups ()
let inherit_fds m =
  let blocking = m |> List.filter_map (fun (dst, _, flags) ->
      match flags with
      | `Blocking -> Some (dst, true)
      | `Nonblocking -> Some (dst, false)
      | `Preserve_blocking -> None
    )
  in
  with_fds m @@ fun m ->
  let plan : action list = Inherit_fds.plan m in
  { run = fun k -> k (Obj.repr (action_dups, plan, blocking)) }