Attempt to get QUIT command (rewrites of some stuff)

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[] +=

chat.ml

@@ -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)))
-

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 =
+let write cli sender name args text =
-  write cli (Command.create 
+  write_command cli (Command.create sender name args text)
-               (Some !(Irc.name))
-               num
-               ([!(cli.nick)] @ args)
-               (Some 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
+                write peer (Some (uhost cli)) command [target] (Some text)
-                              (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 handle_command = handle_command_prereg (None, None, None, None) in
-  let close_handler = ignore in
+    Iobuf.create d fd addr handle_command (fun _ _ -> ())
-    Iobuf.bind d fd command_handler close_handler
     

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
   

iobuf.ml

@@ -7,15 +7,24 @@ type t = {d: Dispatch.t;
           unsent: string ref;
           ibuf: string;
           ibuf_len: int ref;
-          addr: string;
+          addr: Unix.sockaddr;
-          command_handler: (t -> Command.t -> unit) ref;
+          handle_command: command_handler ref;
-	  close_handler: (string -> unit) 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
+	  if n < buflen then begin
-            iobuf.unsent := Str.string_after buf n
+            iobuf.unsent := Str.string_after buf n;
-	  else if Queue.is_empty iobuf.outq then
+	    handle_events iobuf fd tl
-	    Dispatch.modify iobuf.d fd [Dispatch.Input];
+          end else if Queue.is_empty iobuf.outq then
-	  handle_events iobuf fd tl
+            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 create d fd addr handle_command handle_error =
-  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 iobuf = {d = d;
                fd = fd;
-               outq = outq;
+               outq = Queue.create ();
-               unsent = unsent;
+               unsent = ref "";
-               ibuf = ibuf;
+               ibuf = String.create ibuf_max;
-               ibuf_len = ibuf_len;
+               ibuf_len = ref 0;
                addr = addr;
-               command_handler = ref command_handler;
+               handle_command = ref handle_command;
-	       close_handler = ref close_handler}
+               handle_error = ref handle_error;
-  in
+               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

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 create : Dispatch.t -> Unix.file_descr -> Unix.sockaddr -> command_handler -> error_handler -> 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
+
+val addr : t -> string
+val write : t -> Command.t -> unit
+val bind : t -> command_handler -> error_handler -> unit

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 *)
+                 Send "QUIT :foo\r\n";
-                 Recv ":testserver.test PONG testserver.test :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