Source file netsys_posix.ml

(* $Id$ *)

open Unix
open Printf


module Debug = struct
  let enable = ref false
end

let dlog = Netlog.Debug.mk_dlog "Netsys_posix" Debug.enable
let dlogr = Netlog.Debug.mk_dlogr "Netsys_posix" Debug.enable

let () =
  Netlog.Debug.register_module "Netsys_posix" Debug.enable

external int64_of_file_descr : Unix.file_descr -> int64
  = "netsys_int64_of_file_descr"

let int_of_file_descr =
  match Sys.os_type with
  | "Unix" | "Cygwin" ->
    (fun fd -> (Obj.magic (fd:file_descr) : int))
  | _ ->
    (fun fd -> invalid_arg "Netsys.int_of_file_descr")

let file_descr_of_int =
  match Sys.os_type with
  | "Unix" | "Cygwin" ->
    (fun n -> (Obj.magic (n:int) : file_descr))
  | _ ->
    (fun n -> invalid_arg "Netsys.file_descr_of_int")

(* Limits  & resources *)

external sysconf_open_max : unit -> int = "netsys_sysconf_open_max";;

(* misc *)

external fchdir : Unix.file_descr -> unit = "netsys_fchdir" ;;
external fdopendir : Unix.file_descr -> Unix.dir_handle = "netsys_fdopendir" ;;
external realpath : string -> string = "netsys_realpath"
external get_nonblock : Unix.file_descr -> bool = "netsys_get_nonblock"

(* Process groups, sessions, terminals *)

external getpgid : int -> int = "netsys_getpgid";;
let getpgrp() = getpgid 0;;
external setpgid : int -> int -> unit = "netsys_setpgid";;
let setpgrp() = setpgid 0 0;;

external tcgetpgrp : file_descr -> int = "netsys_tcgetpgrp";;
external tcsetpgrp : file_descr -> int -> unit = "netsys_tcsetpgrp";;

external ctermid : unit -> string = "netsys_ctermid";;
external ttyname : file_descr -> string = "netsys_ttyname";;

external getsid : int -> int = "netsys_getsid";;

external posix_openpt : bool -> Unix.file_descr = "netsys_posix_openpt"
external grantpt : Unix.file_descr -> unit = "netsys_grantpt"
external unlockpt : Unix.file_descr -> unit = "netsys_unlockpt"
external ptsname : Unix.file_descr -> string = "netsys_ptsname"


let with_tty f =
  let fd = 
    try Unix.openfile (ctermid()) [Unix.O_RDWR] 0 
    with _ -> failwith "Netsys_posix.with_tty: cannot open terminal" in
  try
    let r = f fd in
    Unix.close fd;
    r
  with error -> Unix.close fd; raise error


let descr_input_line fd = (* unbuffered! *)
  let b = Buffer.create 80 in
  let s = Bytes.create 1 in

  let rec loop () =
    try
      let n = Unix.read fd s 0 1 in
      if n > 0 && Bytes.get s 0 <> '\n' then (
        #ifdef HAVE_BYTES
          Buffer.add_bytes b s;
        #else
        Buffer.add_string b (Bytes.unsafe_to_string s);
      #endif
        raise(Unix.Unix_error(Unix.EINTR,"",""))
)
with
| Unix.Unix_error(Unix.EINTR,_,_) ->
  loop()
in

loop();
Buffer.contents b



let tty_read_password ?(tty=Unix.stdin) prompt =
  if Unix.isatty tty then (
    let cleanup = ref [] in
    let f = Unix.out_channel_of_descr tty in
    output_string f prompt;
    flush f;
    Unix.tcdrain tty;
    Unix.tcflush tty Unix.TCIFLUSH;
    let p = Unix.tcgetattr tty in
    try
      let p' =
        { p with
          Unix.c_echo = false;
          Unix.c_echoe = false;
          Unix.c_echok = false;
          Unix.c_echonl = false
        } in
      Unix.tcsetattr tty Unix.TCSAFLUSH p';
      cleanup := (fun () -> Unix.tcsetattr tty Unix.TCSAFLUSH p) :: !cleanup;
      let old_sigint = 
        Sys.signal Sys.sigint (Sys.Signal_handle(fun _ -> raise Sys.Break)) in
      cleanup := (fun () -> Sys.set_signal Sys.sigint old_sigint) :: !cleanup;
      let pw = descr_input_line tty in
      output_string f "\n";
      flush f;
      List.iter (fun f -> f()) !cleanup;
      pw
    with
    | error ->
      List.iter (fun f -> f()) !cleanup;
      if error = Sys.Break then (
        output_string f "\n";
        flush f
      );
      raise error
  )
  else
    descr_input_line tty


(* Users and groups *)

external setreuid : int -> int -> unit = "netsys_setreuid";;
external setregid : int -> int -> unit = "netsys_setregid";;
external initgroups : string -> int -> unit = "netsys_initgroups"

(* mknod *)

type node_type = 
  | S_IFREG 
  | S_IFCHR of int  (* major + minor *)
  | S_IFBLK of int  (* major + minor *)
  | S_IFIFO
  | S_IFSOCK

external mknod : string -> int -> node_type -> unit = "netsys_mknod"

(* poll *)

external pollfd_size : unit -> int = "netsys_pollfd_size"

let the_pollfd_size = pollfd_size()

let _have_poll = the_pollfd_size > 0
let have_poll() = _have_poll

type poll_req_events = int
type poll_act_events = int
type poll_cell =
  { mutable poll_fd : Unix.file_descr;
    mutable poll_req_events : poll_req_events;
    mutable poll_act_events : poll_act_events;
  }
type poll_mem
type poll_array =
  | Poll_mem of poll_mem * int (*length*)
  | Poll_emu of poll_cell array

let null_poll_cell =
  { poll_fd = Unix.stdin;
    poll_req_events = 0;
    poll_act_events = 0
  }

external mk_poll_mem : int -> poll_mem
  = "netsys_mk_poll_mem"

external set_poll_mem : poll_mem -> int -> Unix.file_descr -> int -> int -> unit
  = "netsys_set_poll_mem"

external get_poll_mem : poll_mem -> int -> (Unix.file_descr * int * int)
  = "netsys_get_poll_mem"

external blit_poll_mem : poll_mem -> int -> poll_mem -> int -> int -> unit
  = "netsys_blit_poll_mem"

external poll_constants : unit -> int array = "netsys_poll_constants"

let the_poll_constants = poll_constants()

let const_rd_event = the_poll_constants.(0)
let const_pri_event = the_poll_constants.(1)
let const_wr_event = the_poll_constants.(2)
let const_err_event = the_poll_constants.(3)
let const_hup_event = the_poll_constants.(4)
let const_nval_event = the_poll_constants.(5)

let poll_req_events rd wr pri =
  (if rd then const_rd_event else 0) lor
  (if wr then const_wr_event else 0) lor
  (if pri then const_pri_event else 0)

let poll_req_triple p =
  (p land const_rd_event <> 0,
   p land const_wr_event <> 0,
   p land const_pri_event <> 0
  )

let poll_null_events() = 0

let poll_result p = p <> 0
let poll_rd_result p = p land const_rd_event <> 0
let poll_wr_result p = p land const_wr_event <> 0
let poll_pri_result p = p land const_pri_event <> 0
let poll_err_result p = p land const_err_event <> 0
let poll_hup_result p = p land const_hup_event <> 0
let poll_nval_result p = p land const_nval_event <> 0

let poll_array_length =
  function
  | Poll_mem(_,n) -> n
  | Poll_emu e -> Array.length e

let set_poll_cell a k c =
  if k < 0 || k >= poll_array_length a then
    invalid_arg "Netsys.set_poll_cell";
  match a with
  | Poll_mem(s,_) ->
    set_poll_mem s k c.poll_fd c.poll_req_events (* c.poll_revents *) 0 
  | Poll_emu e ->
    e.(k) <- { c with poll_fd = c.poll_fd } (* copy *)

let get_poll_cell a k =
  if k < 0 || k >= poll_array_length a then
    invalid_arg "Netsys.get_poll_cell";
  match a with
  | Poll_mem(s,_) ->
    let (fd, ev, rev) = get_poll_mem s k in
    { poll_fd = fd; poll_req_events = ev; poll_act_events = rev }
  | Poll_emu e ->
    let c = e.(k) in
    { c with poll_fd = c.poll_fd }   (* copy *)

let blit_poll_array a1 k1 a2 k2 len =
  let l1 = poll_array_length a1 in
  let l2 = poll_array_length a2 in
  if len < 0 || k1 < 0 || k1+len > l1 || k2 < 0 || k2+len > l2 then
    invalid_arg "Netsys.get_poll_cell";
  match (a1, a2) with
  | (Poll_mem(s1,_), Poll_mem(s2,_)) ->
    blit_poll_mem s1 k1 s2 k2 len
  | (Poll_emu e1, Poll_emu e2) ->
    Array.blit e1 k1 e2 k2 len
  | _ ->
    assert false

let create_poll_array n =
  if _have_poll then (
    let s = mk_poll_mem n in
    Poll_mem(s,n)
  )
  else (
    let e = Array.make n null_poll_cell in
    Poll_emu e
  )

external netsys_poll : poll_mem -> int -> int -> int = "netsys_poll"


let concat_fd_list l =
  String.concat "," 
    (List.map
       (fun fd -> 
          Int64.to_string(int64_of_file_descr fd))
       l
    )


(* win32 only: *)
external netsys_real_select : 
  Unix.file_descr list -> 
  Unix.file_descr list -> 
  Unix.file_descr list -> 
  float ->
  (Unix.file_descr list * Unix.file_descr list * Unix.file_descr list)
  = "netsys_real_select"

let real_select = 
  if Sys.os_type = "Win32" then
    netsys_real_select
  else
    Unix.select


let do_poll a k tmo =
  match a with
  | Poll_mem(s,_) ->
    netsys_poll s k tmo
  | Poll_emu e ->
    (* Emulate poll using Unix.select. This is slow! *)
    let tmo' =
      if tmo < 0 then (-1.0) else float tmo *. 0.001 in
    let l_inp = ref [] in
    let l_out = ref [] in
    let l_pri = ref [] in
    for j = 0 to k-1 do
      let c = e.(j) in
      let (f_inp, f_out, f_pri) = poll_req_triple c.poll_req_events in
      if f_inp then l_inp := c.poll_fd :: !l_inp;
      if f_out then l_out := c.poll_fd :: !l_out;
      if f_pri then l_pri := c.poll_fd :: !l_pri;
    done;
    dlogr (fun () ->
        sprintf "poll_emulation request in=%s out=%s pri=%s tmo=%f"
          (concat_fd_list !l_inp)
          (concat_fd_list !l_out)
          (concat_fd_list !l_pri)
          tmo');
    let (o_inp, o_out, o_pri) = 
      real_select !l_inp !l_out !l_pri tmo' in
    dlogr (fun () ->
        sprintf "poll_emulation result in=%s out=%s pri=%s"
          (concat_fd_list o_inp)
          (concat_fd_list o_out)
          (concat_fd_list o_pri));
    let a_inp = Array.of_list o_inp in
    let a_out = Array.of_list o_out in
    let a_pri = Array.of_list o_pri in
    Array.sort compare a_inp;
    Array.sort compare a_out;
    Array.sort compare a_pri;
    let n = ref 0 in
    for j = 0 to k-1 do
      let c = e.(j) in
      let g_inp = Netsys_impl_util.mem_sorted_array c.poll_fd a_inp in
      let g_out = Netsys_impl_util.mem_sorted_array c.poll_fd a_out in
      let g_pri = Netsys_impl_util.mem_sorted_array c.poll_fd a_pri in
      let rev =
        (if g_inp then const_rd_event else 0) lor
        (if g_out then const_wr_event else 0) lor
        (if g_pri then const_pri_event else 0) in
      c.poll_act_events <- rev;
      if rev <> 0 then incr n
    done;
    !n


let poll a k tmo =
  if k < 0 || k > poll_array_length a then
    invalid_arg "Netsys.poll";
  let r =
    Netsys_impl_util.slice_time_ms
      (fun tmo0 ->
         (* tmo0 is now an int in milliseconds *)
         let n = do_poll a k tmo0 in
         if n = 0 then None else Some n
      )
      tmo in
  match r with
  | None -> 0
  | Some n -> n


let restarting_poll a k tmo =
  Netsys_impl_util.restart_tmo (poll a k) tmo

let poll_single fd r w pri tmo =
  let a = create_poll_array 1 in
  set_poll_cell a 0 { poll_fd = fd; 
                      poll_req_events = poll_req_events r w pri;
                      poll_act_events = poll_null_events()
                    };
  poll a 1 tmo > 0


let act_events_of_int n = n
let int_of_act_events n = n

let req_events_of_int n = n
let int_of_req_events n = n

(* poll aggregation *)

type netsys_event_source
type netsys_event_aggreg

type tagged_event =
  | EV_FD of Unix.file_descr

type event_push =
  { event_id : int;
    event_tag : tagged_event;
    event_api_req : int;
  }

class type event_source =
  object
    method event_id : int
    method event_tag : tagged_event
    method push_record : event_push
    method need_push : bool
    method post_poll : int -> int -> unit
    method upd_kernel_events : int -> unit
    method set_post_modify_callback : (int -> unit) -> unit
    method clear_post_modify_callback : unit -> unit
    method modify_fd_event_source : int -> unit
    method act_events : int
  end

class fd_event_source fd req : event_source =
  let event_id = ref 0 in
  let event_api_req = ref req in
  let event_kernel_req = ref 0 in
  let event_tag = EV_FD fd in
  let act_events = ref 0 in
  let post_modify_callback = ref None in
  object(self)
    initializer (
      let id = Oo.id self in
      event_id := id
    )

    method event_id = !event_id
    method event_tag = event_tag
    method push_record =
      { event_id = !event_id;
        event_tag = event_tag;
        event_api_req= !event_api_req
      }
    method need_push = !event_api_req <> !event_kernel_req
    method upd_kernel_events req =
      event_kernel_req := req;
    method post_poll mask act = 
      event_kernel_req := !event_kernel_req land mask;
      act_events := act
    method set_post_modify_callback f =
      match !post_modify_callback with
      | None -> post_modify_callback := Some f
      | Some _ ->
        failwith "Netsys_posix.add_event_source: the source is already \
                  added to an aggregator"
    method clear_post_modify_callback () =
      post_modify_callback := None
    method modify_fd_event_source req =
      event_api_req := req;
      match !post_modify_callback with
      | Some f -> f !event_id
      | None -> ()
    method act_events = !act_events
  end

let fd_event_source fd req = 
  new fd_event_source fd req

let modify_fd_event_source es req =
  es # modify_fd_event_source req

let get_fd_of_event_source es =
  match es # event_tag with
  | EV_FD fd -> fd

let act_events_of_event_source es =
  es # act_events


external have_event_aggregation : unit -> bool
  = "netsys_have_event_aggregation"

external netsys_create_event_aggreg :
  bool -> netsys_event_aggreg
  = "netsys_create_event_aggreg"

external netsys_destroy_event_aggreg :
  netsys_event_aggreg -> unit
  = "netsys_destroy_event_aggreg"

external netsys_event_aggreg_fd :
  netsys_event_aggreg -> Unix.file_descr
  = "netsys_event_aggreg_fd"

external netsys_push_event_sources : 
  netsys_event_aggreg -> event_push list -> unit
  = "netsys_push_event_sources"

external netsys_add_event_source :
  netsys_event_aggreg -> event_push -> unit
  = "netsys_add_event_source"

external netsys_del_event_source :
  netsys_event_aggreg -> int -> tagged_event -> unit
  = "netsys_del_event_source"

external netsys_poll_event_sources :
  netsys_event_aggreg -> int -> (int * int * int) list
  (* The list are triples (event_id, mask, act) *)
  = "netsys_poll_event_sources"

external netsys_interrupt_aggreg :
  netsys_event_aggreg -> unit
  = "netsys_interrupt_aggreg"

class event_aggregator is_interruptible =
  let up = ref true in
  let all_sources = Hashtbl.create 27 in
  let upd_sources = Hashtbl.create 27 in
  let netsys = netsys_create_event_aggreg is_interruptible in
  let check_up() =
    if not !up then
      failwith "Netsys_posix: This event_aggregator is already destroyed" in
  object(self)
    method add_event_source (es : event_source) =
      check_up();
      es # set_post_modify_callback self#post_modify_callback;
      try
        netsys_add_event_source netsys es#push_record;
        Hashtbl.replace all_sources es#event_id es;
        Hashtbl.replace upd_sources es#event_id es
      with
      | error ->
        es # clear_post_modify_callback();
        raise error
    method del_event_source (es : event_source) =
      check_up();
      if not(Hashtbl.mem all_sources es#event_id) then
        failwith "Netsys_posix.del_event_source: not member of this aggregator";
      netsys_del_event_source netsys es#event_id es#event_tag;
      es # clear_post_modify_callback();
      Hashtbl.remove all_sources es#event_id;
      Hashtbl.remove upd_sources es#event_id
    method post_modify_callback id =
      check_up();
      if (Hashtbl.mem all_sources id) then (
        let es = Hashtbl.find all_sources id in
        Hashtbl.replace upd_sources id es
      )
    method push_event_updates() =
      check_up();
      let l =
        Hashtbl.fold 
          (fun _ es acc -> 
             if es # need_push then
               let p = es#push_record in
               es # upd_kernel_events p.event_api_req;
               p :: acc
             else
               acc
          ) 
          upd_sources
          [] in
      netsys_push_event_sources netsys l;
      Hashtbl.clear upd_sources
    method poll_event_sources tmo =
      self # push_event_updates();
      let v =
        Netsys_impl_util.slice_time_ms
          (fun millis ->
             let evpairs0 = netsys_poll_event_sources netsys millis in
             let evpairs1 = (* without spurious events *)
               List.filter
                 (fun (id,_,_) ->
                    Hashtbl.mem all_sources id
                 )
                 evpairs0 in
             let evpairs2 =
               List.map
                 (fun (id,mask,act) ->
                    let es = Hashtbl.find all_sources id in
                    es#post_poll mask act;
                    Hashtbl.replace upd_sources id es;
                    es
                 )
                 evpairs1 in
             if evpairs2 = [] then
               None
             else
               Some evpairs2
          )
          tmo in
      match v with
      | None -> []
      | Some l -> l
    method event_aggregator_fd =
      check_up();
      netsys_event_aggreg_fd netsys
    method interrupt_event_aggregator() =
      netsys_interrupt_aggreg netsys
    method destroy_event_aggregator () =
      if !up then (
        netsys_destroy_event_aggreg netsys;
        up := false
      )
  end

let create_event_aggregator = new event_aggregator
let add_event_source ea = ea # add_event_source
let del_event_source ea = ea # del_event_source
let push_event_updates ea = ea # push_event_updates()
let poll_event_sources (ea : event_aggregator) = ea # poll_event_sources
let event_aggregator_fd ea = ea # event_aggregator_fd
let destroy_event_aggregator ea = ea # destroy_event_aggregator()
let interrupt_event_aggregator ea = ea # interrupt_event_aggregator()


(* events *)

type not_event

external nsys_create_event : bool -> not_event = "netsys_create_not_event"
external set_nonblock_event : not_event -> unit = "netsys_set_nonblock_not_event"
external get_event_fd_nodup : not_event -> Unix.file_descr = "netsys_get_not_event_fd_nodup"
external set_event : not_event -> unit = "netsys_set_not_event"
external wait_event : not_event -> unit = "netsys_wait_not_event"
external consume_event : not_event -> unit = "netsys_consume_not_event"
external nsys_destroy_event : not_event -> unit = "netsys_destroy_not_event"
external nsys_return_all_event_fd : not_event -> Unix.file_descr list
  = "netsys_return_all_not_event_fd"

let create_event() = 
  let e = nsys_create_event true in
  List.iter
    (fun fd ->
       Netlog.Debug.track_fd
         ~owner:"Netsys_posix" 
         ~descr:"create_event"
         fd;
    )
    (nsys_return_all_event_fd e);
  e

let destroy_event e =
  List.iter
    (fun fd ->
       Netlog.Debug.release_fd fd;
    )
    (nsys_return_all_event_fd e);
  nsys_destroy_event e


let get_event_fd e =
  let fd = get_event_fd_nodup e in
  let fd = Unix.dup fd in
  Unix.set_close_on_exec fd;
  fd


let report_signal_as_event ne signum =
  (* This is simpler to implement in Ocaml than in C:
     - [ne] is kept reachable all the time
     - we can pass [ne] to the handler via a closure
     - we can run non-async-signal-safe stuff in Ocaml signal handlers,
       because they are actually called indirectly
  *)
  Sys.set_signal 
    signum
    (Sys.Signal_handle
       (fun _ ->
          set_event ne
       )
    )

(* post fork handlers *)

class type post_fork_handler =
  object
    method name : string
    method run : unit -> unit
  end

module PFH = struct
  type t = post_fork_handler
  let compare = compare
end

module PFH_Set = Set.Make(PFH)

let post_fork_registry = ref PFH_Set.empty
let post_fork_mutex = !Netsys_oothr.provider # create_mutex()

let register_post_fork_handler pfh =
  post_fork_mutex # lock();
  post_fork_registry := PFH_Set.add pfh !post_fork_registry;
  post_fork_mutex # unlock()

let remove_post_fork_handler pfh =
  post_fork_mutex # lock();
  post_fork_registry := PFH_Set.remove pfh !post_fork_registry;
  post_fork_mutex # unlock()

let run_post_fork_handlers() =
  PFH_Set.iter
    (fun pfh ->
       try pfh#run()
       with
       | error ->
         prerr_endline("Netsys_posix: Exception in post fork handler "
                       ^ pfh#name ^ ": " ^ Netexn.to_string error)
    )
    !post_fork_registry


(* "at" *)

type at_flag = AT_EACCESS | AT_SYMLINK_NOFOLLOW | AT_SYMLINK_FOLLOW | 
               AT_REMOVEDIR

               (* The stubs assume these type definitions: *)
               #ifdef HAVE_O_KEEPEXEC
type open_flag1 = Unix.open_flag =
    O_RDONLY | O_WRONLY | O_RDWR | O_NONBLOCK | O_APPEND | O_CREAT | O_TRUNC
  | O_EXCL | O_NOCTTY | O_DSYNC | O_SYNC | O_RSYNC | O_SHARE_DELETE
  | O_CLOEXEC | O_KEEPEXEC
                #else
  #ifdef HAVE_O_CLOEXEC
type open_flag1 = Unix.open_flag =
    O_RDONLY | O_WRONLY | O_RDWR | O_NONBLOCK | O_APPEND | O_CREAT | O_TRUNC
  | O_EXCL | O_NOCTTY | O_DSYNC | O_SYNC | O_RSYNC | O_SHARE_DELETE
  | O_CLOEXEC
    #else
  #ifdef HAVE_O_SHARE_DELETE
type open_flag1 = Unix.open_flag =
    O_RDONLY | O_WRONLY | O_RDWR | O_NONBLOCK | O_APPEND | O_CREAT | O_TRUNC
  | O_EXCL | O_NOCTTY | O_DSYNC | O_SYNC | O_RSYNC | O_SHARE_DELETE
                                                     #else
type open_flag1 = Unix.open_flag =
    O_RDONLY | O_WRONLY | O_RDWR | O_NONBLOCK | O_APPEND | O_CREAT | O_TRUNC
  | O_EXCL | O_NOCTTY | O_DSYNC | O_SYNC | O_RSYNC
                                           #endif
                                           #endif
                                           #endif

type access_permission1 = Unix.access_permission =
    R_OK | W_OK | X_OK | F_OK


external netsys_at_fdcwd : unit -> Unix.file_descr =
  "netsys_at_fdcwd"

let at_fdcwd = netsys_at_fdcwd()

external have_at : unit -> bool 
  = "netsys_have_at"
external openat :  Unix.file_descr -> string -> Unix.open_flag list -> 
  Unix.file_perm ->  Unix.file_descr
  = "netsys_openat"
external faccessat : Unix.file_descr -> string -> Unix.access_permission list ->
  at_flag list -> unit
  = "netsys_faccessat"
external mkdirat : Unix.file_descr -> string -> int -> unit 
  = "netsys_mkdirat"
external renameat : Unix.file_descr -> string -> Unix.file_descr -> string -> 
  unit
  = "netsys_renameat"
external linkat : Unix.file_descr -> string -> Unix.file_descr -> string ->
  at_flag list -> unit
  = "netsys_linkat"
external unlinkat : Unix.file_descr -> string -> at_flag list -> unit
  = "netsys_unlinkat"
external symlinkat : string -> Unix.file_descr -> string -> unit
  = "netsys_symlinkat"
external mkfifoat : Unix.file_descr -> string -> int -> unit
  = "netsys_mkfifoat"
external readlinkat : Unix.file_descr -> string -> string
  = "netsys_readlinkat"

(* Clocks *)

type timespec = float * int
type clock_id
type clock =
  (* also in Netlog *)
  | CLOCK_REALTIME
  | CLOCK_MONOTONIC
  | CLOCK_ID of clock_id

external nanosleep : timespec -> timespec ref -> unit = "netsys_nanosleep"
external clock_gettime : clock -> timespec = "netsys_clock_gettime"
(* also in Netlog *)
external clock_settime : clock -> timespec -> unit = "netsys_clock_settime"
external clock_getres : clock -> timespec = "netsys_clock_getres"
external clock_getcpuclockid : int -> clock_id = "netsys_clock_getcpuclockid"

type timer_expiration =
  | TEXP_NONE
  | TEXP_EVENT of not_event
  | TEXP_EVENT_CREATE
  | TEXP_SIGNAL of int
type posix_timer

external have_posix_timer : unit -> bool
  = "netsys_have_posix_timer"

external nsys_timer_create : clock -> timer_expiration -> posix_timer
  = "netsys_timer_create"

external timer_settime : posix_timer -> bool -> timespec -> timespec -> unit
  = "netsys_timer_settime"

external timer_gettime : posix_timer -> timespec
  = "netsys_timer_gettime"

external timer_delete : posix_timer -> unit
  = "netsys_timer_delete"

external timer_event : posix_timer -> not_event
  = "netsys_timer_event"

let timer_create clock texp =
  let v = nsys_timer_create clock texp in
  Gc.finalise timer_delete v;
  v

(* Spawn *)

type wd_spec =
  | Wd_keep
  | Wd_chdir of string
  | Wd_fchdir of Unix.file_descr

type pg_spec =
  | Pg_keep
  | Pg_new_bg_group
  | Pg_new_fg_group
  | Pg_join_group of int

type fd_action =
  | Fda_close of Unix.file_descr
  | Fda_close_ignore of Unix.file_descr
  | Fda_close_except of bool array
  | Fda_dup2 of Unix.file_descr * Unix.file_descr

type sig_action =
  | Sig_default of int
  | Sig_ignore of int
  | Sig_mask of int list

external netsys_spawn : wd_spec -> pg_spec -> fd_action list -> 
  sig_action list -> string array ->
  string -> string array -> int
  = "netsys_spawn_byte" "netsys_spawn_nat"

external netsys_posix_spawn : pg_spec -> fd_action list -> 
  sig_action list -> string array ->
  string -> string array -> int
  = "netsys_posix_spawn_byte" "netsys_posix_spawn_nat"

external have_posix_spawn : unit -> bool
  = "netsys_have_posix_spawn"

let spawn ?(chdir = Wd_keep) ?(pg = Pg_keep) ?(fd_actions = [])
    ?(sig_actions = []) ?(env = Unix.environment()) 
    ?(no_posix_spawn=false) cmd args =
  (* Check whether we can use the faster netsys_posix_spawn *)
  let use_posix_spawn =
    not no_posix_spawn &&
    have_posix_spawn() &&
    chdir = Wd_keep &&
    pg <> Pg_new_fg_group &&
    not (List.exists
           (fun sa -> match sa with Sig_ignore _ -> true | _ -> false) 
           sig_actions) in

  try
    if not use_posix_spawn then
      failwith "USE_FORK_EXEC";

    netsys_posix_spawn pg fd_actions sig_actions env cmd args
  (* may also fail with "USE_FORK_EXEC" in some cases *)
  with
  | Failure "USE_FORK_EXEC" ->
    (* Fixup: if pg = Pg_new_fg_group, we remove any Sig_default for
       	   SIGTTOU from sig_actions. Because of special handling, the effect
       	   of Sig_default is enforced by the implementation, but this must be
       	   done at [execve] time.
       	 *)
    let sig_actions =
      if pg = Pg_new_fg_group then
        List.filter 
          (fun spec -> spec <> Sig_default Sys.sigttou)
          sig_actions
      else
        sig_actions in
    netsys_spawn chdir pg fd_actions sig_actions env cmd args

type watched_subprocess = 
  { atom_idx : int;
    mutable alive : bool;
    mutable allocated : bool;
  }

external netsys_watch_subprocess : int -> int -> bool -> Unix.file_descr * int
  = "netsys_watch_subprocess"

external netsys_ignore_subprocess : int -> unit
  = "netsys_ignore_subprocess"

external netsys_forget_subprocess : int -> unit
  = "netsys_forget_subprocess"

external netsys_get_subprocess_status : int -> Unix.process_status option
  = "netsys_get_subprocess_status"

external install_subprocess_handler : unit -> unit
  = "netsys_install_sigchld_handler"

external subprocess_cleanup_after_fork : unit -> unit
  = "netsys_subprocess_cleanup_after_fork"

external netsys_kill_subprocess : int -> int -> unit
  = "netsys_kill_subprocess"

external netsys_killpg_subprocess : int -> int -> unit
  = "netsys_killpg_subprocess"

external kill_all_subprocesses : int -> bool -> bool -> unit
  = "netsys_kill_all_subprocesses"

external killpg_all_subprocesses : int -> bool -> unit
  = "netsys_killpg_all_subprocesses"

let forget_subprocess ws =
  if ws.allocated then (
    netsys_forget_subprocess ws.atom_idx;
    ws.allocated <- false;
  );
  ws.alive <- false

let watch_subprocess pid pgid kill_flag =
  if pid <= 0 || pgid < 0 then
    invalid_arg "Netsys_posix.watch_subprocess";
  let fd, atom_idx = netsys_watch_subprocess pid pgid kill_flag in
  let ws = { atom_idx = atom_idx; alive = true; allocated = true } in
  Gc.finalise forget_subprocess ws;
  (fd, ws)

let ignore_subprocess ws =
  if not ws.alive then
    failwith "Netsys_posix.ignore_subprocess: stale reference";
  netsys_ignore_subprocess ws.atom_idx;
  ws.alive <- false

let get_subprocess_status ws =
  if not ws.alive then
    failwith "Netsys_posix.get_subprocess_status: stale reference";
  netsys_get_subprocess_status ws.atom_idx

let kill_subprocess signal ws =
  if ws.alive then
    netsys_kill_subprocess signal ws.atom_idx

let killpg_subprocess signal ws =
  if ws.alive then
    netsys_killpg_subprocess signal ws.atom_idx


let () =
  register_post_fork_handler
    ( object 
      method name = "subprocess_cleanup_after_fork"
      method run = subprocess_cleanup_after_fork
    end
    )

let register_subprocess_handler() =
  Netsys_signal.register_exclusive_handler
    ~name:"Sigchld handler in Netsys_posix"
    ~signal:Sys.sigchld
    ~install:install_subprocess_handler
    ()


(* locales *)

type langinfo =
  { nl_CODESET : string;
    nl_D_T_FMT : string;
    nl_D_FMT : string;
    nl_T_FMT : string;
    nl_T_FMT_AMPM : string;
    nl_AM_STR : string;
    nl_PM_STR : string;
    nl_DAY_1 : string;
    nl_DAY_2 : string;
    nl_DAY_3 : string;
    nl_DAY_4 : string;
    nl_DAY_5 : string;
    nl_DAY_6 : string;
    nl_DAY_7 : string;
    nl_ABDAY_1 : string;
    nl_ABDAY_2 : string;  
    nl_ABDAY_3 : string;  
    nl_ABDAY_4 : string;  
    nl_ABDAY_5 : string;  
    nl_ABDAY_6 : string;  
    nl_ABDAY_7 : string;  
    nl_MON_1 : string;  
    nl_MON_2 : string;  
    nl_MON_3 : string;  
    nl_MON_4 : string;  
    nl_MON_5 : string;  
    nl_MON_6 : string;  
    nl_MON_7 : string;  
    nl_MON_8 : string;  
    nl_MON_9 : string;  
    nl_MON_10 : string;  
    nl_MON_11 : string;  
    nl_MON_12 : string;  
    nl_ABMON_1 : string;  
    nl_ABMON_2 : string;  
    nl_ABMON_3 : string;  
    nl_ABMON_4 : string;  
    nl_ABMON_5 : string;  
    nl_ABMON_6 : string;  
    nl_ABMON_7 : string;  
    nl_ABMON_8 : string;  
    nl_ABMON_9 : string;  
    nl_ABMON_10 : string;  
    nl_ABMON_11 : string;  
    nl_ABMON_12 : string;  
    nl_ERA : string;  
    nl_ERA_D_FMT : string;  
    nl_ERA_D_T_FMT : string;  
    nl_ERA_T_FMT : string;  
    nl_ALT_DIGITS : string;  
    nl_RADIXCHAR : string;  
    nl_THOUSEP : string;  
    nl_YESEXPR : string;  
    nl_NOEXPR : string;  
    nl_CRNCYSTR : string;  
  }

external netsys_query_langinfo : string -> langinfo = "netsys_query_langinfo"

let cached_langinfo = ref None

let query_langinfo locale =
  if locale = "" then (
    match !cached_langinfo with
    | None ->
      let li = netsys_query_langinfo "" in
      cached_langinfo := Some li;
      li
    | Some li -> li
  )
  else
    netsys_query_langinfo locale



(* syslog *)

type level = Netlog.level

type m_level =
  | LOG_EMERG | LOG_ALERT | LOG_CRIT | LOG_ERR | LOG_WARNING 
  | LOG_NOTICE | LOG_INFO | LOG_DEBUG

let trans_level =
  [ `Emerg, LOG_EMERG;
    `Alert, LOG_ALERT;
    `Crit, LOG_CRIT;
    `Err, LOG_ERR;
    `Warning, LOG_WARNING;
    `Notice, LOG_NOTICE;
    `Info, LOG_INFO;
    `Debug, LOG_DEBUG
  ]

type syslog_facility =
  [ `Authpriv
  | `Cron
  | `Daemon
  | `Ftp
  | `Kern
  | `Local0
  | `Local1
  | `Local2
  | `Local3
  | `Local4
  | `Local5
  | `Local6
  | `Local7
  | `Lpr
  | `Mail
  | `News
  | `Syslog
  | `User
  | `Uucp
  | `Default
  ]

type m_syslog_facility = 
  | LOG_AUTHPRIV
  | LOG_CRON
  | LOG_DAEMON
  | LOG_FTP
  | LOG_KERN
  | LOG_LOCAL0
  | LOG_LOCAL1
  | LOG_LOCAL2
  | LOG_LOCAL3
  | LOG_LOCAL4
  | LOG_LOCAL5
  | LOG_LOCAL6
  | LOG_LOCAL7
  | LOG_LPR
  | LOG_MAIL
  | LOG_NEWS
  | LOG_SYSLOG
  | LOG_USER
  | LOG_UUCP
  | LOG_DEFAULT

let trans_facility =
  [ `Authpriv, LOG_AUTHPRIV;
    `Cron, LOG_CRON;
    `Daemon, LOG_DAEMON;
    `Ftp, LOG_FTP;
    `Kern, LOG_KERN;
    `Local0, LOG_LOCAL0;
    `Local1, LOG_LOCAL1;
    `Local2, LOG_LOCAL2;
    `Local3, LOG_LOCAL3;
    `Local4, LOG_LOCAL4;
    `Local5, LOG_LOCAL5;
    `Local6, LOG_LOCAL6;
    `Local7, LOG_LOCAL7;
    `Lpr, LOG_LPR;
    `Mail, LOG_MAIL;
    `News, LOG_NEWS;
    `Syslog, LOG_SYSLOG;
    `User, LOG_USER;
    `Uucp, LOG_UUCP;
    `Default, LOG_DEFAULT;
  ]

type syslog_option =
  [ `Cons
  | `Ndelay
  | `Odelay
  | `Nowait
  | `Pid
  ]

type m_syslog_option =
  | LOG_CONS
  | LOG_NDELAY
  | LOG_ODELAY
  | LOG_NOWAIT
  | LOG_PID

let trans_syslog_option =
  [ `Cons, LOG_CONS;
    `Ndelay, LOG_NDELAY;
    `Odelay, LOG_ODELAY;
    `Nowait, LOG_NOWAIT;
    `Pid, LOG_PID;
  ]

external netsys_openlog : 
  string option -> m_syslog_option list -> m_syslog_facility -> unit
  = "netsys_openlog"

external netsys_syslog :
  m_syslog_facility -> m_level -> string -> unit
  = "netsys_syslog"

external netsys_closelog : unit -> unit = "netsys_closelog"

let openlog id_opt opts fac =
  try
    netsys_openlog
      id_opt
      ( List.map
          (fun p -> List.assoc p trans_syslog_option)
          opts
      )
      ( List.assoc fac trans_facility )
  with
  | Not_found -> assert false

let syslog fac lev msg =
  try
    netsys_syslog
      ( List.assoc fac trans_facility )
      ( List.assoc lev trans_level )
      msg
  with
  | Not_found -> assert false

let closelog = netsys_closelog


(* Sync *)

external fsync : Unix.file_descr -> unit = "netsys_fsync"
external fdatasync : Unix.file_descr -> unit = "netsys_fdatasync"


(* Optional POSIX functions *)

external have_fadvise : unit -> bool = "netsys_have_posix_fadvise"
type advice =
  | POSIX_FADV_NORMAL
  | POSIX_FADV_SEQUENTIAL
  | POSIX_FADV_RANDOM
  | POSIX_FADV_NOREUSE
  | POSIX_FADV_WILLNEED
  | POSIX_FADV_DONTNEED
  | FADV_NORMAL
  | FADV_SEQUENTIAL
  | FADV_RANDOM
  | FADV_NOREUSE
  | FADV_WILLNEED
  | FADV_DONTNEED
external fadvise : Unix.file_descr -> int64 -> int64 -> advice -> unit
  = "netsys_fadvise"

external have_fallocate : unit -> bool = "netsys_have_posix_fallocate"
external fallocate : Unix.file_descr -> int64 -> int64 -> unit
  = "netsys_fallocate"

(* POSIX shared memory *)

external have_posix_shm : unit -> bool = "netsys_have_posix_shm"
type shm_open_flag =
  | SHM_O_RDONLY
  | SHM_O_RDWR
  | SHM_O_CREAT
  | SHM_O_EXCL
  | SHM_O_TRUNC
external shm_open : string -> shm_open_flag list -> int -> file_descr
  = "netsys_shm_open"
external shm_unlink : string -> unit = "netsys_shm_unlink"

let shm_create prefix size =
  let pid = Unix.getpid() in
  let t = Unix.gettimeofday() in
  let rec loop n =
    let id = sprintf "%d/%f/%d" pid t n in
    let dg = Digest.to_hex (Digest.string id) in
    let dg8 = String.sub dg 0 8 in
    let name = sprintf "%s_%s" prefix dg8 in
    try
      let fd =
        shm_open
          name [SHM_O_RDWR; SHM_O_CREAT; SHM_O_EXCL ] 0o600 in
      ( try Unix.fchmod fd 0o600
        with Unix.Unix_error(Unix.EINVAL,_,_) -> ()
        (* OSX seems to throw EINVAL here *)
      );
      if size > 0 then
        Unix.ftruncate fd size;
      (fd, name)
    with
    | Unix.Unix_error(Unix.EEXIST,_,_) ->
      loop (n+1) in
  loop 0


type sem_kind = [ `Named | `Anonymous ]

type sem_rep

type 'sem_kind semaphore =
  Netsys_types.memory * sem_rep
(* We keep a reference to the bigarray to prevent that it is
   collected while a semaphore is stored in it
*)

type named_semaphore = [ `Named ] semaphore
type anon_semaphore = [ `Anonymous ] semaphore

type sem_open_flag =
  | SEM_O_CREAT
  | SEM_O_EXCL

type sem_wait_behavior =
  | SEM_WAIT_BLOCK
  | SEM_WAIT_NONBLOCK

let dummy_mem =
  Bigarray.Array1.create Bigarray.char Bigarray.c_layout 0

external have_anon_posix_semaphores : unit -> bool 
  = "netsys_have_sem_anon"

external have_named_posix_semaphores : unit -> bool 
  = "netsys_have_sem_named"

let have_posix_semaphores() =
  have_anon_posix_semaphores() && have_named_posix_semaphores()

external netsys_sem_size : unit -> int
  = "netsys_sem_size"

external netsys_sem_value_max : unit -> int
  = "netsys_sem_value_max"

let sem_size = netsys_sem_size()

let sem_value_max = netsys_sem_value_max()


external netsys_sem_open :
  string -> sem_open_flag list -> int -> int -> sem_rep
  = "netsys_sem_open"

let sem_open name flags mode init_value =
  if init_value < 0 || init_value > sem_value_max then
    invalid_arg "Netsys_posix.sem_open";
  let sr = netsys_sem_open name flags mode init_value in
  (dummy_mem, sr)

external netsys_sem_close : sem_rep -> unit 
  = "netsys_sem_close"

let sem_close (_,sr) = netsys_sem_close sr

external sem_unlink : string -> unit 
  = "netsys_sem_unlink"

let sem_create prefix initval =
  let pid = Unix.getpid() in
  let t = Unix.gettimeofday() in
  let rec loop n =
    let id = sprintf "%d/%f/%d" pid t n in
    let dg = Digest.to_hex (Digest.string id) in
    let dg8 = String.sub dg 0 8 in
    let name = sprintf "%s_%s" prefix dg8 in
    try
      let sem =
        sem_open
          name [SEM_O_CREAT; SEM_O_EXCL] 0o600 initval in
      (sem, name)
    with
    | Unix.Unix_error(Unix.EEXIST,_,_) ->
      loop (n+1) in
  loop 0


external netsys_sem_init : 
  Netsys_types.memory -> int -> bool -> int -> sem_rep
  = "netsys_sem_init"

let sem_init mem pos pshared init_value =
  if pos < 0 || pos > Bigarray.Array1.dim mem - sem_size then
    invalid_arg "Netsys_posix.sem_init";
  if init_value < 0 || init_value > sem_value_max then
    invalid_arg "Netsys_posix.sem_init";
  let sr = netsys_sem_init mem pos pshared init_value in
  (mem,sr)

external netsys_as_sem : Netsys_types.memory -> int -> sem_rep
  = "netsys_as_sem"

let as_sem mem pos = 
  if pos < 0 || pos > Bigarray.Array1.dim mem - sem_size then
    invalid_arg "Netsys_posix.as_sem";
  let sr = netsys_as_sem mem pos in
  (mem,sr)

external netsys_sem_destroy : sem_rep -> unit
  = "netsys_sem_destroy"

let sem_destroy (_,sr) = netsys_sem_destroy sr

external netsys_sem_getvalue : sem_rep -> int
  = "netsys_sem_getvalue"

let sem_getvalue (_,sr) = netsys_sem_getvalue sr

external netsys_sem_post : sem_rep -> unit
  = "netsys_sem_post"

let sem_post (_,sr) = netsys_sem_post sr

external netsys_sem_wait : sem_rep -> sem_wait_behavior -> unit
  = "netsys_sem_wait"

let sem_wait (_,sr) b = netsys_sem_wait sr b


type ioprio_target =
  | Ioprio_process of int
  | Ioprio_pgrp of int
  | Ioprio_user of int

type ioprio =
  | Noprio
  | Real_time of int
  | Best_effort of int
  | Idle

external ioprio_get : ioprio_target -> ioprio = "netsys_ioprio_get"
external ioprio_set : ioprio_target -> ioprio -> unit = "netsys_ioprio_set"

let have_ioprio() =
  try let _ = ioprio_get(Ioprio_process(Unix.getpid())) in true
  with _ -> false