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
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
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)) }

external action_setpgid : unit -> fork_fn = "eio_unix_fork_setpgid"
let action_setpgid = action_setpgid ()
let setpgid pgid =
  { run = fun k -> k (Obj.repr (action_setpgid, 0, pgid)) }

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)) }

external action_setgid : unit -> fork_fn = "eio_unix_fork_setgid"
let action_setgid = action_setgid ()
let setgid gid = {
  run = fun k -> k (Obj.repr (action_setgid, gid)) }

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

external error_of_code : int -> Unix.error = "eio_unix_error_of_code"

let report_spawn_error msg =
  (* A failed fork action writes "<fn>:<errno>" to the errors pipe. *)
  match Scanf.sscanf_opt msg "%[^:]:%d" (fun fn code -> (fn, error_of_code code)) with
  | Some (fn, err) -> raise (Unix.Unix_error (err, fn, ""))
  | None -> failwith msg