From 667062bf9353a2ee02966879b3bf5e057f354e33 Mon Sep 17 00:00:00 2001 From: Neale Pickett Date: Tue, 18 Mar 2008 15:27:03 -0600 Subject: [PATCH] Complete transition to epoll, all unit tests passing --- OMakefile | 4 +- client.ml | 22 +++++------ client.mli | 2 +- command.ml | 2 +- iobuf.ml | 96 ++++++++++++++++++----------------------------- iobuf.mli | 7 ++-- irc.ml | 4 -- ircd.ml | 34 +++++++++-------- tests.ml | 107 ++++++++++++++++++++++++----------------------------- 9 files changed, 121 insertions(+), 157 deletions(-) diff --git a/OMakefile b/OMakefile index 7de7099..0757195 100644 --- a/OMakefile +++ b/OMakefile @@ -1,6 +1,4 @@ OCAMLPACKS[] = - equeue - pcre str OCAML_CLIBS = ocamlepoll OCAMLCFLAGS += -g @@ -26,7 +24,7 @@ section dispatch_tests.cmo: dispatch_tests$(EXT_OBJ): - OCamlProgram(tests, tests dispatch chat irc command iobuf client channel) + OCamlProgram(tests, tests dispatch irc command iobuf client channel) .PHONY: test test: tests diff --git a/client.ml b/client.ml index 44ab1d0..59a3033 100644 --- a/client.ml +++ b/client.ml @@ -40,7 +40,7 @@ let reply cli num ?(args=[]) text = ([!(cli.nick)] @ args) (Some text)) -let handle_close cli () = +let handle_close cli message = Hashtbl.remove by_nick !(cli.nick) let handle_command cli iobuf cmd = @@ -161,22 +161,22 @@ let set_nick cli nick = Hashtbl.replace by_nick nick cli; cli.nick := nick -let rec handle_command_prereg (nick', username', realname', password') iobuf cmd = +let rec handle_command_prereg (nick, username, realname, password) iobuf cmd = (* Handle a command during the login phase *) let acc = match (Command.as_tuple cmd) with - | (None, "PASS", [password], None) -> - (nick', username', realname', Some password) - | (None, "USER", [username; _; _], Some realname) -> - (nick', Some username, Some (Irc.truncate realname 40), password') - | (None, "NICK", [nick], None) -> - (Some nick, username', realname', password') + | (None, "PASS", [password'], None) -> + (nick, username, realname, Some password') + | (None, "USER", [username'; _; _], Some realname') -> + (nick, Some username', Some (Irc.truncate realname' 40), password) + | (None, "NICK", [nick'], None) -> + (Some nick', username, realname, password) | _ -> Iobuf.write iobuf (Command.create (Some !(Irc.name)) "451" ["*"] (Some "Register first.")); - (nick', username', realname', password') + (nick, username, realname, password) in let welcome cli = try @@ -211,8 +211,8 @@ let rec handle_command_prereg (nick', username', realname', password') iobuf cmd | _ -> Iobuf.rebind iobuf (handle_command_prereg acc) ignore -let handle_connection ues grp fd = +let handle_connection d fd addr = let command_handler = handle_command_prereg (None, None, None, None) in let close_handler = ignore in - Iobuf.bind ues grp fd command_handler close_handler + Iobuf.bind d fd command_handler close_handler diff --git a/client.mli b/client.mli index c0c3640..f2adb02 100644 --- a/client.mli +++ b/client.mli @@ -1,5 +1,5 @@ type t val write : t -> Command.t -> unit -val handle_connection : Unixqueue.event_system -> Unixqueue.group -> Unix.file_descr -> unit +val handle_connection : Dispatch.t -> Unix.file_descr -> Unix.sockaddr -> unit diff --git a/command.ml b/command.ml index 7d1295e..d9241b9 100644 --- a/command.ml +++ b/command.ml @@ -39,7 +39,7 @@ let extract_word s = let rec from_string line = (* Very simple. Pull out words until you get one starting with ":". The very first word might start with ":", that doesn't count - because it's the sender.. *) + because it's the sender. *) let rec loop sender acc line = let c = (if (line = "") then None else (Some line.[0])) in match (c, acc) with diff --git a/iobuf.ml b/iobuf.ml index 3d89b2f..a6740d1 100644 --- a/iobuf.ml +++ b/iobuf.ml @@ -1,8 +1,7 @@ -(* ========================================== - * I/O buf stuff - *) -type t = {ues: Unixqueue.event_system; - grp: Unixqueue.group; +(* ************************************** + * IRC Command I/O buffers + * **************************************) +type t = {d: Dispatch.t; fd: Unix.file_descr; outq: Command.t Queue.t; unsent: string ref; @@ -10,39 +9,24 @@ type t = {ues: Unixqueue.event_system; ibuf_len: int ref; addr: string; command_handler: (t -> Command.t -> unit) ref; - close_handler: (unit -> unit) ref} + close_handler: (string -> unit) ref} let ibuf_max = 4096 let max_outq = 50 let obuf_max = 4096 -let by_file_descr = Hashtbl.create 25 - let addr iobuf = iobuf.addr let write iobuf cmd = let was_empty = Queue.is_empty iobuf.outq in Queue.add cmd iobuf.outq; if (was_empty && (!(iobuf.unsent) = "")) then - Unixqueue.add_resource - iobuf.ues iobuf.grp (Unixqueue.Wait_out iobuf.fd, -.1.0) + Dispatch.modify iobuf.d iobuf.fd [Dispatch.Input; Dispatch.Output] -let close iobuf = - !(iobuf.close_handler) (); - Hashtbl.remove by_file_descr iobuf.fd; - Unix.close iobuf.fd; - Unixqueue.remove_resource iobuf.ues iobuf.grp (Unixqueue.Wait_in iobuf.fd); - try - Unixqueue.remove_resource iobuf.ues iobuf.grp (Unixqueue.Wait_out iobuf.fd); - with Not_found -> - () - -let handle_close fd = - try - let iobuf = Hashtbl.find by_file_descr fd in - close iobuf - with Not_found -> - () +let close iobuf message = + !(iobuf.close_handler) message; + Dispatch.delete iobuf.d iobuf.fd; + Unix.close iobuf.fd let crlf = Str.regexp "\r?\n" @@ -63,27 +47,22 @@ let handle_input iobuf = in loop lines -let handle_event ues esys e = - match e with - | Unixqueue.Input_arrived (g, fd) -> - let iobuf = Hashtbl.find by_file_descr fd in +let rec handle_events iobuf fd events = + match events with + | [] -> + () + | Dispatch.Input :: tl -> let size = ibuf_max - !(iobuf.ibuf_len) in let len = Unix.read fd iobuf.ibuf !(iobuf.ibuf_len) size in - if (len > 0) then - begin - iobuf.ibuf_len := !(iobuf.ibuf_len) + len; - try - handle_input iobuf - with Not_found -> - if (!(iobuf.ibuf_len) = ibuf_max) then - (* No newline found, and the buffer is full *) - raise (Failure "Buffer overrun"); - end - else - close iobuf - | Unixqueue.Output_readiness (g, fd) -> + iobuf.ibuf_len := !(iobuf.ibuf_len) + len; + handle_input iobuf; + if (!(iobuf.ibuf_len) = ibuf_max) then + (* No newline found, and the buffer is full *) + close iobuf "Input buffer overrun" + else + handle_events iobuf fd tl + | Dispatch.Output :: tl -> (* XXX: Could be optimized to try and fill the output buffer *) - let iobuf = Hashtbl.find by_file_descr fd in let buf = if (!(iobuf.unsent) = "") then let cmd = Queue.pop iobuf.outq in @@ -96,17 +75,19 @@ let handle_event ues esys e = if n < buflen then iobuf.unsent := Str.string_after buf n else if Queue.is_empty iobuf.outq then - Unixqueue.remove_resource ues g (Unixqueue.Wait_out fd) - | Unixqueue.Out_of_band (g, fd) -> - print_endline "oob" - | Unixqueue.Timeout (g, op) -> - print_endline "timeout" - | Unixqueue.Signal -> - print_endline "signal" - | Unixqueue.Extra exn -> - print_endline "extra" + Dispatch.modify iobuf.d fd [Dispatch.Input]; + handle_events iobuf fd tl + | Dispatch.Priority :: tl -> + let s = String.create 4096 in + ignore (Unix.recv fd s 0 4096 [Unix.MSG_OOB]); + handle_events iobuf fd tl + | Dispatch.Error :: tl -> + close iobuf "Error" + | Dispatch.Hangup :: tl -> + close iobuf "Hangup" -let bind ues grp fd command_handler close_handler = + +let bind d fd command_handler close_handler = let (outq, unsent, ibuf, ibuf_len) = (Queue.create (), ref "", String.create ibuf_max, ref 0) in @@ -117,8 +98,7 @@ let bind ues grp fd command_handler close_handler = | Unix.ADDR_INET (addr, port) -> Unix.string_of_inet_addr addr in - let iobuf = {ues = ues; - grp = grp; + let iobuf = {d = d; fd = fd; outq = outq; unsent = unsent; @@ -128,9 +108,7 @@ let bind ues grp fd command_handler close_handler = command_handler = ref command_handler; close_handler = ref close_handler} in - Hashtbl.replace by_file_descr fd iobuf; - Unixqueue.add_resource ues grp (Unixqueue.Wait_in fd, -.1.0); - Unixqueue.add_close_action ues grp (fd, handle_close) + Dispatch.add d fd (handle_events iobuf) [Dispatch.Input] let rebind t command_handler close_handler = t.command_handler := command_handler; diff --git a/iobuf.mli b/iobuf.mli index c869dda..8edd1e3 100644 --- a/iobuf.mli +++ b/iobuf.mli @@ -3,7 +3,6 @@ type t val addr : t -> string val write : t -> Command.t -> unit -val bind : Unixqueue.event_system -> Unixqueue.group -> Unix.file_descr -> (t -> Command.t -> unit) -> (unit -> unit) -> unit -val rebind: t -> (t -> Command.t -> unit) -> (unit -> unit) -> unit -val close: t -> unit -val handle_event : Unixqueue.event_system -> Unixqueue.event Equeue.t -> Unixqueue.event -> unit +val bind : Dispatch.t -> Unix.file_descr -> (t -> Command.t -> unit) -> (string -> unit) -> unit +val rebind: t -> (t -> Command.t -> unit) -> (string -> unit) -> unit +val close: t -> string -> unit diff --git a/irc.ml b/irc.ml index cdd35ce..eff55a3 100644 --- a/irc.ml +++ b/irc.ml @@ -1,10 +1,6 @@ let name = ref "irc.test" let version = "0.1" -let newline_re = Pcre.regexp "\n\r?" -let argsep_re = Pcre.regexp " :" -let space_re = Pcre.regexp " " - let dbg msg a = prerr_endline ("[" ^ msg ^ "]"); a diff --git a/ircd.ml b/ircd.ml index de73202..500923a 100644 --- a/ircd.ml +++ b/ircd.ml @@ -7,32 +7,34 @@ let dbg msg a = [connection_handler] will be called with the file descriptor of any new connections. *) -let establish_server ues connection_handler addr = - let g = Unixqueue.new_group ues in - let handle_event ues esys e = - match e with - | Unixqueue.Input_arrived (g, fd) -> +let establish_server d connection_handler addr = + let rec handle_event fd events = + match events with + | [] -> + () + | Dispatch.Input :: tl -> let cli_fd, cli_addr = Unix.accept fd in - connection_handler cli_fd - | _ -> - raise Equeue.Reject + connection_handler cli_fd cli_addr; + handle_event fd tl + | Dispatch.Hangup :: tl -> + Dispatch.delete d fd; + handle_event fd tl + | _ :: tl -> + handle_event fd tl in let srv = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in Unix.bind srv addr; Unix.listen srv 50; Unix.setsockopt srv Unix.SO_REUSEADDR true; - Unixqueue.add_handler ues g handle_event; - Unixqueue.add_resource ues g (Unixqueue.Wait_in srv, -.1.0) + Dispatch.add d fd handle_event [Dispatch.Input]; let main () = - let ues = Unixqueue.create_unix_event_system () in - let g = Unixqueue.new_group ues in - Unixqueue.add_handler ues g Iobuf.handle_event; + let d = Dispatch.create 50 in establish_server ues - Client.handle_connection - (Unix.ADDR_INET (Unix.inet_addr_any, 7777)); - ues#run () + (Client.handle_connection d) + (Unix.ADDR_INET (Unix.inet_addr_any, 6667)); + Dispatch.run d let _ = main () diff --git a/tests.ml b/tests.ml index 3ac0bad..aac9bba 100644 --- a/tests.ml +++ b/tests.ml @@ -1,6 +1,4 @@ -open Unixqueue open OUnit -open Irc let dump x = Printf.ksprintf (fun str -> prerr_string str; flush stderr) x @@ -88,29 +86,29 @@ let chat d fd s = let ibuf = Buffer.create 4096 in let handle_timer _ = failwith (Printf.sprintf "fd=%d timeout waiting for %s" - (int_of_file_descr fd) - (string_of_chat_event (List.hd !script))) + (int_of_file_descr fd) + (string_of_chat_event (List.hd !script))) in let nomatch got = failwith (Printf.sprintf "fd=%d expecting %s\n got %s" - (int_of_file_descr fd) - (string_of_chat_event (List.hd !script)) - (String.escaped got)) + (int_of_file_descr fd) + (string_of_chat_event (List.hd !script)) + (String.escaped got)) in let rec run_script fd = match !script with | [] -> - if ((Buffer.length obuf) = 0) then begin + if ((Buffer.length obuf) = 0) then begin Dispatch.delete_timer d timer; - (try - Dispatch.delete d fd - with (Failure _) -> - ()); + (try + Dispatch.delete d fd + with (Failure _) -> + ()); Unix.close fd - end + end | Send buf :: tl -> Buffer.add_string obuf buf; - Dispatch.modify d fd [Dispatch.Input; Dispatch.Output]; + Dispatch.modify d fd [Dispatch.Input; Dispatch.Output]; script := tl; run_script fd | Recv buf :: tl -> @@ -127,8 +125,8 @@ let chat d fd s = ((String.length ibuf_str) - buf_len); run_script fd end else - nomatch ibuf_str - end else + nomatch ibuf_str + end else () | Regex buf :: tl -> let ibuf_str = Buffer.contents ibuf in @@ -145,7 +143,7 @@ let chat d fd s = ((String.length ibuf_str) - match_len); run_script fd else - nomatch ibuf_str + nomatch ibuf_str else () @@ -159,25 +157,25 @@ let chat d fd s = let n = Unix.read fd s 0 4096 in Buffer.add_substring ibuf s 0 n; run_script fd; - handler fd tl + handler fd tl | Dispatch.Output :: tl -> - begin + begin if ((Buffer.length obuf) = 0) then Dispatch.modify d fd [Dispatch.Input] else let ostr = Buffer.contents obuf in let olen = Buffer.length obuf in let n = Unix.write fd ostr 0 olen in - Buffer.clear obuf; - Buffer.add_substring obuf ostr n (olen - n) - end; - handler fd tl + Buffer.clear obuf; + Buffer.add_substring obuf ostr n (olen - n) + end; + handler fd tl | Dispatch.Hangup :: tl -> - (* Stop listening to this fd, it will always return Hangup *) - (try - Dispatch.delete d fd - with (Failure _) -> - ()) + (* Stop listening to this fd, it will always return Hangup *) + (try + Dispatch.delete d fd + with (Failure _) -> + ()) | _ -> failwith "Unexpected event" in @@ -258,7 +256,7 @@ let unit_tests = last_timer := time in - let s = String.create 4096 in + let s = String.create 4096 in assert_equal 8 (Unix.write a "dispatch" 0 8); Dispatch.add d b handle [Dispatch.Input; Dispatch.Output]; @@ -275,15 +273,15 @@ let unit_tests = Dispatch.once d; assert_equal ~printer:string_of_float 0.0 !last_timer; - Dispatch.modify d b [Dispatch.Input]; - Dispatch.once d; - if (!last_timer = 0.0) then - (* Give it one chance *) - Dispatch.once d; + Dispatch.modify d b [Dispatch.Input]; + Dispatch.once d; + if (!last_timer = 0.0) then + (* Give it one chance *) + Dispatch.once d; assert_equal ~printer:string_of_float time !last_timer; - Dispatch.modify d b [Dispatch.Input; Dispatch.Output]; - assert_equal 6 (Unix.write a "gnarly" 0 6); + Dispatch.modify d b [Dispatch.Input; Dispatch.Output]; + assert_equal 6 (Unix.write a "gnarly" 0 6); Dispatch.once d; assert_equal (b, [Dispatch.Input; Dispatch.Output]) !last_event; assert_equal 6 (Unix.read b s 0 4096); @@ -335,7 +333,6 @@ let unit_tests = ); ] -(* let do_login nick = [ Send ("USER " ^ nick ^ " +iw " ^ nick ^ " :gecos\r\n"); @@ -378,12 +375,11 @@ let regression_tests = Recv ":testserver.test 401 nick otherguy :No such nick/channel\r\n"; ] in - let g = Unixqueue.new_group ues in + let d = Dispatch.create 2 in let a,b = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in - Unixqueue.add_handler ues g Iobuf.handle_event; - Client.handle_connection ues g a; - ignore (new chat_handler script ues b); - chat_run ues); + Client.handle_connection d a (Unix.getpeername a); + chat d b script; + Dispatch.run d); "Second connection" >:: (fun () -> @@ -394,12 +390,11 @@ let regression_tests = Recv ":testserver.test 303 otherguy :otherguy\r\n"; ] in - let g = Unixqueue.new_group ues in + let d = Dispatch.create 2 in let a,b = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in - Unixqueue.add_handler ues g Iobuf.handle_event; - Client.handle_connection ues g a; - ignore (new chat_handler script ues b); - chat_run ues); + Client.handle_connection d a (Unix.getpeername a); + chat d b script; + Dispatch.run d); "Simultaneous connections" >:: (fun () -> @@ -421,20 +416,16 @@ let regression_tests = Recv ":alice!alice@UDS PRIVMSG bob :Hi Bob!\r\n"; ] in - let g = Unixqueue.new_group ues in + let d = Dispatch.create 4 in let aa,ab = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in let ba,bb = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in - Unixqueue.add_handler ues g Iobuf.handle_event; - Client.handle_connection ues g aa; - Client.handle_connection ues g ba; - ignore (new chat_handler script1 ues ab); - ignore (new chat_handler script2 ues bb); - chat_run ues); + Client.handle_connection d aa (Unix.getpeername aa); + Client.handle_connection d ba (Unix.getpeername ba); + chat d ab script1; + chat d bb script2; + Dispatch.run d); ] -*) let _ = Irc.name := "testserver.test"; - run_test_tt_main (TestList [unit_tests (*; regression_tests *)]) - - + run_test_tt_main (TestList [unit_tests; regression_tests])