Skip to content
This repository
tag: v664
Fetching contributors…

Cannot retrieve contributors at this time

file 213 lines (184 sloc) 6.982 kb
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 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)

(* THIS FILE HAS A DOCUMENTED MLI *)

(* error reporting *)
type error = int * string
let error_code = fst
let error_message = snd
exception Error of error

(* epoll descriptor *)
type epoll_descriptor = int

#<Ifstatic:MLSTATE_WINDOWS .*>
let last_error_message _ = assert false
let last_error_code _ = assert false
let ep_create _ = assert false
let ep_close _ = assert false
let ep_in _ = assert false
let ep_out _ = assert false
let ep_err _ = assert false
let ep_hup _ = assert false
let _on_mac _ = assert false
let on_mac = false
#<Else>
external last_error_message : unit -> string = "error_msg"
external last_error_code : unit -> int = "error_value"
external ep_create : int -> epoll_descriptor = "ep_create"
external ep_close : epoll_descriptor -> int = "ep_close"
external ep_in : unit -> int = "ep_EPOLLIN"
external ep_out : unit -> int = "ep_EPOLLOUT"
external ep_err : unit -> int = "ep_EPOLLERR"
external ep_hup : unit -> int = "ep_EPOLLHUP"
external _on_mac : unit -> bool = "on_mac"
let on_mac = _on_mac ()
#<End>

(* check_ret factory *)
let check_ret str ret =
  if ret = -1 then
    let message = Printf.sprintf "%s: %s" str (last_error_message ()) in
    let code = last_error_code () in
    Logger.error "Epoll error %d: %s" code message(* ; *)
    (* raise (Error (code, message)) *)

(* events *)
type supported_event = In | Out | Hup | Err | Unsupported of int

type event = int
type event_mask = int

let event_in, event_out, event_in_out, event_hup, event_err =
    let u() =(ep_in(), ep_out(), (ep_in() lor ep_out()), ep_hup(), ep_err()) in
    let z()= (0, 0, 0, 0, 0) in
    Mlstate_platform.platform_dependent
      ~unix:u
      ~cygwin:z
      ~windows:z
      () ()

let event_mask_to_list event_mask =
  (* Frequent cases have to be memoized *)
  if event_mask = event_in then [In] else
  if event_mask = event_out then [Out] else
  if event_mask = (event_in lor event_out) then [In; Out]
  else begin
    let f (r, l) (ie, ee) = if ((ie land r) = ie) then ((ie lxor r), ee::l) else (r, l) in
    let rec aux (event_mask, event_list) events =
      if event_mask = 0 then event_list
      else (
        match events with
        | [] -> (Unsupported event_mask)::event_list
        | h::t -> aux (f (event_mask, event_list) h) t
      )
    in
    aux (event_mask, []) [(event_in, In); (event_out, Out); (event_hup, Hup); (event_err, Err)]
  end


let event_list_to_mask event_list =
  List.fold_left
    (fun e_mask ee ->
       let ie =
         match ee with
         | In -> event_in
         | Out -> event_out
         | Err -> event_err
         | Hup -> event_hup
         | Unsupported e -> e
       in
       ie lor e_mask
    ) 0 event_list

(* requests *)

(* low level : private *)
#<Ifstatic:MLSTATE_WINDOWS .*>
let ep_add _ _ _ = assert false
let ep_del _ _ _ = assert false
let ep_mod _ _ _ = assert false
let ep_wait _ ~maxevents ~timeout =
  let _ = ignore (maxevents, timeout) in
    assert false
#<Else>
external ep_add : epoll_descriptor -> Unix.file_descr -> event_mask-> int = "ep_add"
external ep_del : epoll_descriptor -> Unix.file_descr -> event_mask -> int = "ep_del"
external ep_mod : epoll_descriptor -> Unix.file_descr -> event_mask -> int = "ep_mod"
external ep_wait : epoll_descriptor -> maxevents : int -> timeout : int -> (Unix.file_descr * event_mask) array = "ep_wait"
#<End>

(* high level : exported *)

(* The test [if int_of_filedesc fd >= 0 then] is there because weblib is also used with
dummy_connection (cf doc in mli). Dummy connections build negative file descriptor
In this case, Epoll ignore these file descriptors.
*)
external int_of_filedesc : Unix.file_descr -> int = "%identity"
external filedesc_of_int : int -> Unix.file_descr = "%identity"
external int_of_epoll_descriptor : epoll_descriptor -> int = "%identity"
external epoll_descriptor_of : int -> epoll_descriptor = "%identity"

let combine =
  List.fold_left (lor) 0

let create size =
  Mlstate_platform.on_windows (fun()->failwith "ep_create on windows");
  let ret = ep_create size in
  check_ret "epoll_create" ret;
  epoll_descriptor_of ret (* normally useless ?? *)

let close ed = check_ret "epoll_close" (ep_close ed)

let del epfd fd =
  Mlstate_platform.on_windows (fun()->failwith "ep_del on windows");
  if int_of_filedesc fd >= 0 then
    let ret =
      if on_mac then (
        let _ = ep_del epfd fd event_in in
        ep_del epfd fd event_out )
      else
        ep_del epfd fd 0
    in
    check_ret "epoll_del" ret

let listen_in_out epfd ?(is_new_fd=false) fd =
  if int_of_filedesc fd >= 0 then
    let ret =
      if on_mac then (
        let _ = ep_add epfd fd event_in in
        ep_add epfd fd event_out )
      else (
        if is_new_fd then
          ep_add epfd fd event_in_out
        else
          ep_mod epfd fd event_in_out )
    in
    check_ret "listen_in_out" ret

let listen_x_only x y epfd is_new_fd fd =
  if int_of_filedesc fd >= 0 then
    let ret =
      if on_mac then (
        let _ = ep_del epfd fd y in
        ep_add epfd fd x )
      else (
        if is_new_fd then
          ep_add epfd fd x
        else
          ep_mod epfd fd x )
    in
    check_ret "listen_x_only" ret

let listen_in_only epfd is_new_fd fd = listen_x_only event_in event_out epfd is_new_fd fd
let listen_out_only epfd is_new_fd fd = listen_x_only event_out event_in epfd is_new_fd fd

let wait ?tout:(timeout = -1) epfd maxevents =
  Mlstate_platform.on_windows (fun()->failwith "ep_wait on windows");
  let a = ep_wait epfd ~maxevents ~timeout in
  Array.map (fun (fd, events) -> (fd, event_mask_to_list events)) a

module Debug =
struct
  (* This functions are used only for printing file descriptors and events (useful for debugging) *)
  (* http://caml.inria.fr/pub/ml-archives/caml-list/2002/06/b0e3d11df12ca90608634197c0792939.en.html *)
  external int_of_filedescr : Unix.file_descr -> int = "%identity"
  external filedescr_of_int : int -> Unix.file_descr = "%identity"
  external int_of_events : event_mask -> int = "%identity"
  external int_of_epoll_descriptor : epoll_descriptor -> int = "%identity"

  (* tests *)
(* let test() = *)
(* let fd = create (10) in *)
(* add fd Unix.stdout event_in; *)
(* add fd Unix.stdin event_in; *)
(* let arr = wait fd 10 in *)
(* Printf.printf "Got: %d\n" (Array.length arr) *)
end
Something went wrong with that request. Please try again.