irc-bot/dispatch.ml

129 lines
3.0 KiB
OCaml

type event = Input | Priority | Output | Error | Hangup
type timer_handler = float -> unit
type fd_handler = Unix.file_descr -> event list -> unit
module Timer =
Set.Make (struct
type t = (float * timer_handler)
let compare = compare
end)
module Fd_map =
Map.Make (struct
type t = Unix.file_descr
let compare = compare
end)
type t = {
e : Epoll.t;
fds : (fd_handler * event list) Fd_map.t ref;
numfds : int ref;
timers : Timer.t ref;
}
let to_epoll = function
| Input -> Epoll.In
| Priority -> Epoll.Priority
| Output -> Epoll.Out
| Error -> Epoll.Error
| Hangup -> Epoll.Hangup
let from_epoll = function
| Epoll.In -> Input
| Epoll.Priority -> Priority
| Epoll.Out -> Output
| Epoll.Error -> Error
| Epoll.Hangup -> Hangup
let rec epoll_events_of_events = List.map to_epoll
let rec events_of_epoll_events = List.map from_epoll
let create size =
{e = Epoll.create size;
fds = ref Fd_map.empty;
numfds = ref 0;
timers = ref Timer.empty}
let destroy d =
Epoll.destroy d.e;
(* Explicitly unreference fds and timers, in case d sticks around *)
d.fds := Fd_map.empty;
d.numfds := 0;
d.timers := Timer.empty
let add d fd handler events =
Epoll.ctl d.e Epoll.Add (fd, (epoll_events_of_events events));
d.fds := Fd_map.add fd (handler, events) !(d.fds);
d.numfds := !(d.numfds) + 1
let modify d fd events =
Epoll.ctl d.e Epoll.Modify (fd, (epoll_events_of_events events))
let set_handler d fd handler =
let (_, events) = Fd_map.find fd !(d.fds) in
d.fds := Fd_map.add fd (handler, events) !(d.fds)
let delete d fd =
Epoll.ctl d.e Epoll.Delete (fd, []);
d.fds := Fd_map.remove fd !(d.fds);
d.numfds := !(d.numfds) - 1
let add_timer d time handler =
d.timers := Timer.add (time, handler) !(d.timers)
let delete_timer d time =
let may_remain (time', _) =
time' <> time
in
d.timers := Timer.filter may_remain !(d.timers)
let rec dispatch_timers d now =
if (!(d.timers) != Timer.empty) then
let (time, handler) = Timer.min_elt !(d.timers) in
if now > time then
()
else begin
handler time;
d.timers := Timer.remove (time, handler) !(d.timers);
dispatch_timers d now
end
let rec dispatch_results d events_list =
match events_list with
| [] ->
()
| (fd, epoll_events) :: tl ->
let handler, _ = Fd_map.find fd !(d.fds) in
let events = events_of_epoll_events epoll_events in
handler fd events;
dispatch_results d tl
let once d =
let now = Unix.time () in
let timeout =
try
let (time, _) = Timer.min_elt !(d.timers) in
let timeout_s = max (time -. now) 0.0 in
int_of_float (timeout_s *. 1000.0)
with Not_found ->
-1
in
let result = Epoll.wait d.e !(d.numfds) timeout in
dispatch_timers d (Unix.time ());
dispatch_results d result
let rec run d =
if ((!(d.fds) == Fd_map.empty) &&
(!(d.timers) == Timer.empty)) then
()
else begin
once d;
run d
end