diff --git a/OMakefile b/OMakefile index 0757195..08faa8d 100644 --- a/OMakefile +++ b/OMakefile @@ -7,7 +7,7 @@ OCAMLCFLAGS += -g StaticCLibrary(ocamlepoll, epoll_wrapper) -OCamlProgram(ircd, ircd irc command iobuf client channel) +OCamlProgram(ircd, ircd irc command iobuf dispatch client channel) section OCAMLPACKS[] += diff --git a/chat.ml b/chat.ml deleted file mode 100644 index f5f0469..0000000 --- a/chat.ml +++ /dev/null @@ -1,188 +0,0 @@ -open Unixqueue - -exception Buffer_overrun - -type chat_event = - | Send of string - | Recv of string - | Regex of string - -exception Chat_match of (string * chat_event) -exception Chat_timeout of chat_event - -let dbg msg a = prerr_endline msg; a - -let string_of_chat_event e = - match e with - | Send str -> - ("Send (\"" ^ (String.escaped str) ^ "\")") - | Recv str -> - ("Recv (\"" ^ (String.escaped str) ^ "\")") - | Regex str -> - ("Regex (\"" ^ (String.escaped str) ^ "\")") - -(** Return true if str starts with substr *) -let startswith str substr = - let l = String.length substr in - if l > String.length str then - false - else - String.sub str 0 l = substr - - -(** Return all but the first index chars in a string *) -let string_after str index = - let l = String.length str in - String.sub str index (l - index) - - -(** Read a chunk of bytes from fd *) -let read_fd fd = - let s = 4096 in - let buf = String.create s in - let len = Unix.read fd buf 0 s in - String.sub buf 0 len - - -class chat_handler chatscript - ?(input_timeout=0.1) - ?(output_timeout = 0.1) - ?(output_max = 4096) - ?(input_max = 4096) - (ues : unix_event_system) fd = -object (self) - val g = ues#new_group () - val mutable debug = false - - - val obuf = String.create output_max - val mutable obuf_len = 0 - - val mutable script = chatscript - val inbuf = Buffer.create 4096 - - initializer - ues#add_handler g self#handle_event; - ues#add_resource g (Wait_in fd, input_timeout); - self#run_script (); - - method write data = - let data_len = String.length data in - if (data_len + obuf_len > output_max) then - raise Buffer_overrun; - String.blit data 0 obuf obuf_len data_len; - obuf_len <- obuf_len + data_len; - ues#add_resource g (Wait_out fd, output_timeout) - - method handle_event ues esys e = - match e with - | Input_arrived (g, fd) -> - let data = String.create input_max in - let len = Unix.read fd data 0 input_max in - if (len > 0) then - begin - Buffer.add_string inbuf (String.sub data 0 len); - self#run_script () - end - else - begin - Unix.close fd; - ues#clear g; - end - | Output_readiness (g, fd) -> - let size = obuf_len in - let n = Unix.single_write fd obuf 0 size in - obuf_len <- obuf_len - n; - if (obuf_len = 0) then - (* Don't check for output readiness anymore *) - begin - ues#remove_resource g (Wait_out fd) - end - else - (* Put unwritten output back into the output queue *) - begin - String.blit obuf n obuf 0 (obuf_len) - end - | Out_of_band (g, fd) -> - raise (Failure "Out of band data") - | Timeout (g, op) -> - raise (Chat_timeout (List.hd script)) - | Signal -> - raise (Failure "Signal") - | Extra exn -> - raise (Failure "Extra") - - method run_script () = - match script with - | [] -> - Unix.close fd; - ues#clear g - | Send buf :: tl -> - self#write buf; - script <- tl; - self#run_script () - | Recv buf :: tl -> - let buf_len = String.length buf in - let inbuf_str = Buffer.contents inbuf in - if (Buffer.length inbuf >= buf_len) then - if startswith inbuf_str buf then - begin - script <- tl; - Buffer.clear inbuf; - Buffer.add_substring - inbuf - inbuf_str - buf_len - ((String.length inbuf_str) - buf_len); - self#run_script () - end - else - raise (Chat_match (inbuf_str, Recv buf)) - else - () - | Regex buf :: tl -> - let inbuf_str = Buffer.contents inbuf in - let matched = Str.string_match (Str.regexp buf) inbuf_str 0 in - if (Buffer.length inbuf > 0) then - if matched then - let match_len = Str.match_end () in - script <- tl; - Buffer.clear inbuf; - Buffer.add_substring - inbuf - inbuf_str - match_len - ((String.length inbuf_str) - match_len); - self#run_script () - else - raise (Chat_match (inbuf_str, Regex buf)) - else - () -end - - -let chat_create ues script proc = - let a,b = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in - ignore (proc ues a); - ignore (new chat_handler script ues b) - -(** Run a chat script - - [chat script proc] will create a Unix domain socket pair, call [proc - ues fd] with the event system and one of the sockets, and then run - [script] through it. -*) - -let chat_run ues = - try - Unixqueue.run ues; - with - | Chat_match (got, expected) -> - raise (Failure ("Not matched: got \"" ^ - (String.escaped got) ^ - "\"\n expected " ^ - (string_of_chat_event expected))) - | Chat_timeout evt -> - raise (Failure ("Timeout waiting for " ^ - (string_of_chat_event evt))) - diff --git a/client.ml b/client.ml index 59a3033..8a3ceb2 100644 --- a/client.ml +++ b/client.ml @@ -30,17 +30,16 @@ let uhost cli = let close cli = Iobuf.close cli.iobuf -let write cli cmd = +let write_command cli cmd = Iobuf.write cli.iobuf cmd -let reply cli num ?(args=[]) text = - write cli (Command.create - (Some !(Irc.name)) - num - ([!(cli.nick)] @ args) - (Some text)) +let write cli sender name args text = + write_command cli (Command.create sender name args text) -let handle_close cli message = +let reply cli num ?(args=[]) text = + write cli (Some !(Irc.name)) num ([!(cli.nick)] @ args) (Some text) + +let handle_error cli iobuf message = Hashtbl.remove by_nick !(cli.nick) let handle_command cli iobuf cmd = @@ -51,8 +50,12 @@ let handle_command cli iobuf cmd = () | (None, "SERVICE", [nickname; _; distribution; svctype; _], Some info) -> () - | (None, "QUIT", [], message) -> - () + | (None, "QUIT", [], None) -> + write cli (Some !(Irc.name)) "ERROR" [] (Some "So long"); + Iobuf.close iobuf "No reason provided" + | (None, "QUIT", [], Some message) -> + write cli (Some !(Irc.name)) "ERROR" [] (Some "So long"); + Iobuf.close iobuf message | (None, "JOIN", ["0"], None) -> () | (None, "JOIN", [channels], None) -> @@ -81,11 +84,7 @@ let handle_command cli iobuf cmd = begin try let peer = lookup target in - write peer (Command.create - (Some (uhost cli)) - command - [target] - (Some text)) + write peer (Some (uhost cli)) command [target] (Some text) with Not_found -> reply cli "401" ~args:[target] "No such nick/channel" end @@ -131,7 +130,7 @@ let handle_command cli iobuf cmd = () | (None, "PING", [], Some text) | (None, "PING", [text], None) -> - write cli (Command.create (Some !(Irc.name)) "PONG" [!(Irc.name)] (Some text)) + write cli (Some !(Irc.name)) "PONG" [!(Irc.name)] (Some text) | (None, "PONG", [payload], None) -> () | (None, "ERROR", [], Some message) -> @@ -189,7 +188,7 @@ let rec handle_command_prereg (nick, username, realname, password) iobuf cmd = " " ^ Irc.version ^ " " ^ modes ^ " " ^ Channel.modes); - Iobuf.rebind iobuf (handle_command cli) (handle_close cli) + Iobuf.bind iobuf (handle_command cli) (handle_error cli) with Error cmd -> Iobuf.write iobuf cmd in @@ -209,10 +208,9 @@ let rec handle_command_prereg (nick, username, realname, password) iobuf cmd = username = username; realname = realname} | _ -> - Iobuf.rebind iobuf (handle_command_prereg acc) ignore + Iobuf.bind iobuf (handle_command_prereg acc) (fun _ _ -> ()) let handle_connection d fd addr = - let command_handler = handle_command_prereg (None, None, None, None) in - let close_handler = ignore in - Iobuf.bind d fd command_handler close_handler + let handle_command = handle_command_prereg (None, None, None, None) in + Iobuf.create d fd addr handle_command (fun _ _ -> ()) diff --git a/client.mli b/client.mli index f2adb02..0c7ddc7 100644 --- a/client.mli +++ b/client.mli @@ -1,5 +1,6 @@ type t -val write : t -> Command.t -> unit +val write_command : t -> Command.t -> unit +val write : t -> string option -> string -> string list -> string option -> unit val handle_connection : Dispatch.t -> Unix.file_descr -> Unix.sockaddr -> unit diff --git a/iobuf.ml b/iobuf.ml index a6740d1..3826236 100644 --- a/iobuf.ml +++ b/iobuf.ml @@ -7,15 +7,24 @@ type t = {d: Dispatch.t; unsent: string ref; ibuf: string; ibuf_len: int ref; - addr: string; - command_handler: (t -> Command.t -> unit) ref; - close_handler: (string -> unit) ref} + addr: Unix.sockaddr; + handle_command: command_handler ref; + handle_error: error_handler ref; + valid: bool ref} +and command_handler = t -> Command.t -> unit +and error_handler = t -> string -> unit + let ibuf_max = 4096 let max_outq = 50 let obuf_max = 4096 -let addr iobuf = iobuf.addr +let addr iobuf = + match iobuf.addr with + | Unix.ADDR_UNIX s -> + "UDS" + | Unix.ADDR_INET (addr, port) -> + Unix.string_of_inet_addr addr let write iobuf cmd = let was_empty = Queue.is_empty iobuf.outq in @@ -23,11 +32,6 @@ let write iobuf cmd = if (was_empty && (!(iobuf.unsent) = "")) then Dispatch.modify iobuf.d iobuf.fd [Dispatch.Input; Dispatch.Output] -let close iobuf message = - !(iobuf.close_handler) message; - Dispatch.delete iobuf.d iobuf.fd; - Unix.close iobuf.fd - let crlf = Str.regexp "\r?\n" let handle_input iobuf = @@ -42,11 +46,16 @@ let handle_input iobuf = String.blit leftover 0 iobuf.ibuf 0 !(iobuf.ibuf_len) | line :: tl -> let parsed = Command.from_string line in - !(iobuf.command_handler) iobuf parsed; + !(iobuf.handle_command) iobuf parsed; loop tl in loop lines +let close iobuf message = + !(iobuf.handle_error) iobuf message; + iobuf.valid := false; + Dispatch.modify iobuf.d iobuf.fd [Dispatch.Input; Dispatch.Output] + let rec handle_events iobuf fd events = match events with | [] -> @@ -72,11 +81,18 @@ let rec handle_events iobuf fd events = in let buflen = String.length buf in let n = Unix.single_write fd buf 0 buflen in - if n < buflen then - iobuf.unsent := Str.string_after buf n - else if Queue.is_empty iobuf.outq then - Dispatch.modify iobuf.d fd [Dispatch.Input]; - handle_events iobuf fd tl + if n < buflen then begin + iobuf.unsent := Str.string_after buf n; + handle_events iobuf fd tl + end else if Queue.is_empty iobuf.outq then + if !(iobuf.valid) then begin + Dispatch.modify iobuf.d fd [Dispatch.Input]; + handle_events iobuf fd tl + end else begin + (* Close invalid connection after all output has despooled *) + Dispatch.delete iobuf.d iobuf.fd; + Unix.close iobuf.fd + end | Dispatch.Priority :: tl -> let s = String.create 4096 in ignore (Unix.recv fd s 0 4096 [Unix.MSG_OOB]); @@ -86,30 +102,19 @@ let rec handle_events iobuf fd events = | Dispatch.Hangup :: tl -> close iobuf "Hangup" +let bind iobuf handle_command handle_error = + iobuf.handle_command := handle_command; + iobuf.handle_error := handle_error -let bind d fd command_handler close_handler = - let (outq, unsent, ibuf, ibuf_len) = - (Queue.create (), ref "", String.create ibuf_max, ref 0) - in - let addr = - match Unix.getpeername fd with - | Unix.ADDR_UNIX s -> - "UDS" - | Unix.ADDR_INET (addr, port) -> - Unix.string_of_inet_addr addr - in +let create d fd addr handle_command handle_error = let iobuf = {d = d; fd = fd; - outq = outq; - unsent = unsent; - ibuf = ibuf; - ibuf_len = ibuf_len; + outq = Queue.create (); + unsent = ref ""; + ibuf = String.create ibuf_max; + ibuf_len = ref 0; addr = addr; - command_handler = ref command_handler; - close_handler = ref close_handler} - in + handle_command = ref handle_command; + handle_error = ref handle_error; + valid = ref true} in Dispatch.add d fd (handle_events iobuf) [Dispatch.Input] - -let rebind t command_handler close_handler = - t.command_handler := command_handler; - t.close_handler := close_handler diff --git a/iobuf.mli b/iobuf.mli index 8edd1e3..2d0c370 100644 --- a/iobuf.mli +++ b/iobuf.mli @@ -1,8 +1,11 @@ type t -val addr : t -> string +type command_handler = t -> Command.t -> unit +type error_handler = t -> string -> unit -val write : t -> Command.t -> 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 create : Dispatch.t -> Unix.file_descr -> Unix.sockaddr -> command_handler -> error_handler -> unit val close: t -> string -> unit + +val addr : t -> string +val write : t -> Command.t -> unit +val bind : t -> command_handler -> error_handler -> unit diff --git a/tests.ml b/tests.ml index aac9bba..7c9edfe 100644 --- a/tests.ml +++ b/tests.ml @@ -404,8 +404,8 @@ let regression_tests = Send "ISON bob\r\n"; Recv ":testserver.test 303 alice :bob\r\n"; Send "PRIVMSG bob :Hi Bob!\r\n"; - Send "PING :foo\r\n"; (* Make sure we don't disconnect too soon *) - Recv ":testserver.test PONG testserver.test :foo\r\n"; + Send "QUIT :foo\r\n"; + Recv ":testserver.test ERROR :So long\r\n"; ] in let script2 = @@ -414,6 +414,8 @@ let regression_tests = Send "ISON alice\r\n"; Recv ":testserver.test 303 bob :alice\r\n"; Recv ":alice!alice@UDS PRIVMSG bob :Hi Bob!\r\n"; + Send "QUIT :foo\r\n"; + Recv ":testserver.test ERROR :So long\r\n"; ] in let d = Dispatch.create 4 in