hphp/hack/src/utils/sys/daemon.ml

   1 (**
   2  * Copyright (c) 2015, Facebook, Inc.
   3  * All rights reserved.
   4  *
   5  * This source code is licensed under the BSD-style license found in the
   6  * LICENSE file in the "hack" directory of this source tree. An additional grant
   7  * of patent rights can be found in the PATENTS file in the same directory.
   8  *
   9  *)
  10
  11 type 'a in_channel = Timeout.in_channel
  12 type 'a out_channel = Pervasives.out_channel
  13
  14 type ('in_, 'out) channel_pair = 'in_ in_channel * 'out out_channel
  15
  16 type ('in_, 'out) handle = {
  17   channels : ('in_, 'out) channel_pair;
  18   pid : int;
  19 }
  20
  21 (* Windows: ensure that the serialize/deserialize functions
  22    for the custom block of "Unix.file_descr" are registred. *)
  23 let () = Lazy.force Handle.init
  24
  25 let to_channel :
  26   'a out_channel -> ?flags:Marshal.extern_flags list -> ?flush:bool ->
  27   'a -> unit =
  28   fun oc ?(flags = []) ?flush:(should_flush=true) v ->
  29     Marshal.to_channel oc v flags;
  30     if should_flush then flush oc
  31
  32 let from_channel : ?timeout:Timeout.t -> 'a in_channel -> 'a = fun ?timeout ic ->
  33   Timeout.input_value ?timeout ic
  34
  35 let flush : 'a out_channel -> unit = Pervasives.flush
  36
  37 let descr_of_in_channel : 'a in_channel -> Unix.file_descr =
  38   Timeout.descr_of_in_channel
  39
  40 let descr_of_out_channel : 'a out_channel -> Unix.file_descr =
  41   Unix.descr_of_out_channel
  42
  43 let cast_in ic = ic
  44 let cast_out oc = oc
  45
  46 (* We cannot fork() on Windows, so in order to emulate this in a
  47  * cross-platform way, we use create_process() and set the HH_SERVER_DAEMON
  48  * environment variable to indicate which function the child should
  49  * execute. On Unix, create_process() does fork + exec, so global state is
  50  * not copied; in particular, if you have set a mutable reference the
  51  * daemon will not see it. All state must be explicitly passed via
  52  * environment variables; see set/get_context() below.
  53  *
  54  * With some factoring we could make the daemons into separate binaries
  55  * altogether and dispense with this emulation. *)
  56
  57 module Entry : sig
  58
  59   (* All the 'untyped' operations---that are required for the
  60      entry-points hashtable and the parameters stored in env
  61      variable---are hidden in this sub-module, behind a 'type-safe'
  62      interface. *)
  63
  64   type ('param, 'input, 'output) t
  65   val name_of_entry: ('param, 'input, 'output) t -> string
  66   val register:
  67     string -> ('param -> ('input, 'output) channel_pair -> unit) ->
  68     ('param, 'input, 'output) t
  69   val find:
  70     ('param, 'input, 'output) t ->
  71     'param ->
  72     ('input, 'output) channel_pair -> unit
  73   val set_context:
  74     ('param, 'input, 'output) t -> 'param ->
  75     Unix.file_descr * Unix.file_descr ->
  76     unit
  77   val get_context:
  78     unit ->
  79     (('param, 'input, 'output) t * 'param * ('input, 'output) channel_pair)
  80   val clear_context:
  81     unit -> unit
  82
  83 end = struct
  84
  85   type ('param, 'input, 'output) t = string
  86
  87   let name_of_entry name = name
  88
  89   (* Store functions as 'Obj.t' *)
  90   let entry_points : (string, Obj.t) Hashtbl.t = Hashtbl.create 23
  91   let register name f =
  92     if Hashtbl.mem entry_points name then
  93       Printf.ksprintf failwith
  94         "Daemon.register_entry_point: duplicate entry point %S."
  95         name;
  96     Hashtbl.add entry_points name (Obj.repr f);
  97     name
  98
  99   let find name =
 100     try Obj.obj (Hashtbl.find entry_points name)
 101     with Not_found ->
 102       Printf.ksprintf failwith
 103         "Unknown entry point %S" name
 104
 105   let set_context entry param (ic, oc) =
 106     let data = (ic, oc, param) in
 107     Unix.putenv "HH_SERVER_DAEMON" entry;
 108     let file, oc =
 109       Filename.open_temp_file
 110         ~mode:[Open_binary]
 111         ~temp_dir:Sys_utils.temp_dir_name
 112         "daemon_param" ".bin" in
 113     output_value oc data;
 114     close_out oc;
 115     Unix.putenv "HH_SERVER_DAEMON_PARAM" file
 116
 117   (* How this works on Unix: It may appear like we are passing file descriptors
 118    * from one process to another here, but in_handle / out_handle are actually
 119    * file descriptors that are already open in the current process -- they were
 120    * created by the parent process before it did fork + exec. However, since
 121    * exec causes the child to "forget" everything, we have to pass the numbers
 122    * of these file descriptors as arguments.
 123    *
 124    * I'm not entirely sure what this does on Windows. *)
 125   let get_context () =
 126     let entry = Unix.getenv "HH_SERVER_DAEMON" in
 127     if entry = "" then raise Not_found;
 128     let (in_handle, out_handle, param) =
 129       try
 130         let file = Sys.getenv "HH_SERVER_DAEMON_PARAM" in
 131         if file = "" then raise Not_found;
 132         let ic = Sys_utils.open_in_bin_no_fail file in
 133         let res = Marshal.from_channel ic in
 134         Sys_utils.close_in_no_fail "Daemon.get_context" ic;
 135         Sys.remove file;
 136         res
 137       with exn ->
 138         failwith "Can't find daemon parameters." in
 139     (entry, param,
 140      (Timeout.in_channel_of_descr in_handle,
 141       Unix.out_channel_of_descr out_handle))
 142
 143   let clear_context () =
 144     Unix.putenv "HH_SERVER_DAEMON" "";
 145     Unix.putenv "HH_SERVER_DAEMON_PARAM" "";
 146
 147 end
 148
 149 type ('param, 'input, 'output) entry = ('param, 'input, 'output) Entry.t
 150
 151 let exec entry param ic oc =
 152   let f = Entry.find entry in
 153   try f param (ic, oc); exit 0
 154   with e ->
 155     prerr_endline (Printexc.to_string e);
 156     Printexc.print_backtrace stderr;
 157     exit 2
 158
 159 let register_entry_point = Entry.register
 160
 161 let fd_of_path path =
 162   Sys_utils.with_umask 0o111 begin fun () ->
 163     Sys_utils.mkdir_no_fail (Filename.dirname path);
 164     Unix.openfile path [Unix.O_RDWR; Unix.O_CREAT; Unix.O_TRUNC] 0o666
 165   end
 166
 167 let null_fd () = fd_of_path Sys_utils.null_path
 168
 169 let setup_channels channel_mode =
 170   match channel_mode with
 171   | `pipe ->
 172     let parent_in, child_out = Unix.pipe () in
 173     let child_in, parent_out = Unix.pipe () in
 174     (* Close descriptors on exec so they are not leaked. *)
 175     Unix.set_close_on_exec parent_in;
 176     Unix.set_close_on_exec parent_out;
 177     (parent_in, child_out), (child_in, parent_out)
 178   | `socket ->
 179     let parent_fd, child_fd = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in
 180     (** FD's on sockets are bi-directional. *)
 181     (parent_fd, child_fd), (child_fd, parent_fd)
 182
 183 let make_pipe (descr_in, descr_out)  =
 184   let ic = Timeout.in_channel_of_descr descr_in in
 185   let oc = Unix.out_channel_of_descr descr_out in
 186   ic, oc
 187
 188 let close_pipe channel_mode (ch_in, ch_out) =
 189   match channel_mode with
 190   | `pipe ->
 191     Timeout.close_in ch_in;
 192     close_out ch_out
 193   | `socket ->
 194     (** the in and out FD's are the same. Close only once. *)
 195     Timeout.close_in ch_in
 196
 197 (* This only works on Unix, and should be avoided as far as possible. Use
 198  * Daemon.spawn instead. *)
 199 let fork
 200     ?(channel_mode = `pipe)
 201     (type param)
 202     (log_stdout, log_stderr) (f : param -> ('a, 'b) channel_pair -> unit)
 203     (param : param) : ('b, 'a) handle =
 204   let (parent_in, child_out), (child_in, parent_out)
 205       = setup_channels channel_mode in
 206     let (parent_in, child_out) = make_pipe (parent_in, child_out) in
 207     let (child_in, parent_out) = make_pipe (child_in, parent_out) in
 208   match Fork.fork () with
 209   | -1 -> failwith "Go get yourself a real computer"
 210   | 0 -> (* child *)
 211     (try
 212       ignore(Unix.setsid());
 213       close_pipe channel_mode (parent_in, parent_out);
 214       Sys_utils.with_umask 0o111 begin fun () ->
 215         let fd = null_fd () in
 216         Unix.dup2 fd Unix.stdin;
 217         Unix.close fd;
 218       end;
 219       Unix.dup2 log_stdout Unix.stdout;
 220       Unix.dup2 log_stderr Unix.stderr;
 221       if log_stdout <> Unix.stdout then Unix.close log_stdout;
 222       if log_stderr <> Unix.stderr && log_stderr <> log_stdout then
 223         Unix.close log_stderr;
 224       f param (child_in, child_out);
 225       exit 0
 226     with e ->
 227       prerr_endline (Printexc.to_string e);
 228       Printexc.print_backtrace stderr;
 229       exit 1)
 230   | pid -> (* parent *)
 231     close_pipe channel_mode (child_in, child_out);
 232     { channels = parent_in, parent_out; pid }
 233
 234 let spawn
 235     (type param) (type input) (type output)
 236     ?(channel_mode = `pipe)
 237     ?name
 238     (stdin, stdout, stderr)
 239     (entry: (param, input, output) entry)
 240     (param: param) : (output, input) handle =
 241   let (parent_in, child_out), (child_in, parent_out) =
 242     setup_channels channel_mode in
 243   Entry.set_context entry param (child_in, child_out);
 244   let exe = Sys_utils.executable_path () in
 245   let name = Option.value ~default:(Entry.name_of_entry entry) name in
 246   let pid = Unix.create_process exe [|exe; name|] stdin stdout stderr in
 247   Entry.clear_context ();
 248   (match channel_mode with
 249   | `pipe ->
 250     Unix.close child_in;
 251     Unix.close child_out;
 252   | `socket ->
 253     (** the in and out FD's are the same. Close only once. *)
 254     Unix.close child_in);
 255
 256   let close_if_open fd =
 257     try Unix.close fd
 258     with Unix.Unix_error (Unix.EBADF, _, _) -> ()
 259   in
 260   if stdin <> Unix.stdin then close_if_open stdin;
 261   if stdout <> Unix.stdout then close_if_open stdout;
 262   if stderr <> Unix.stderr && stderr <> stdout then close_if_open stderr;
 263
 264   PidLog.log
 265     ~reason:(Entry.name_of_entry entry)
 266     ~no_fail:true
 267     pid;
 268   { channels = Timeout.in_channel_of_descr parent_in,
 269                Unix.out_channel_of_descr parent_out;
 270     pid }
 271
 272 (* for testing code *)
 273 let devnull () =
 274   let ic = Timeout.open_in "/dev/null" in
 275   let oc = open_out "/dev/null" in
 276   {channels = ic, oc; pid = 0}
 277
 278 (**
 279  * In order for the Daemon infrastructure to work, the beginning of your
 280  * program (or very close to the beginning) must start with a call to
 281  * check_entry_point.
 282  *
 283  * Details: Daemon.spawn essentially does a fork then exec of the currently
 284  * running program. Thus, the child process will just end up running the exact
 285  * same program as the parent if you forgot to start with a check_entry_point.
 286  * The parent process sees this as a NOOP when its program starts, but a
 287  * child process (from Daemon.spawn) will use this as a GOTO to its entry
 288  * point.
 289  *)
 290 let check_entry_point () =
 291   try
 292     let entry, param, (ic, oc) = Entry.get_context () in
 293     Entry.clear_context ();
 294     exec entry param ic oc
 295   with Not_found -> ()
 296
 297 let close { channels = (ic, oc); _ } =
 298   Timeout.close_in ic;
 299   close_out oc
 300
 301 let kill h =
 302   close h;
 303   Sys_utils.terminate_process h.pid
 304
 305 let close_out = close_out
 306 let output_string = output_string
 307 let flush = flush
 308
 309 let close_in = Timeout.close_in
 310 let input_char ic = Timeout.input_char ic
 311 let input_value ic = Timeout.input_value ic