More modules, now parsing commands

This is where I realized that there's no point in passing around a
"server" object, since it's entirely reasonable to expect one server
per running instance.

OMakefile

@@ -6,7 +6,7 @@ OCAMLPACKS[] =
 
 .DEFAULT: ircd
 
-OCamlProgram(ircd, ircd irc client server)
+OCamlProgram(ircd, ircd irc command client channel)
 
 section
     OCAMLPACKS[] +=
@@ -16,7 +16,7 @@ section
     tests.cmi:
     tests$(EXT_OBJ):
 
-    OCamlProgram(tests, tests chat ircd irc client server)
+    OCamlProgram(tests, tests chat ircd irc command client channel)
 
 .PHONY: clean
 clean:

channel.ml

@@ -0,0 +1,9 @@
+type t = {name: string}
+
+let by_name = Hashtbl.create 25
+
+let lookup name =
+  Hashtbl.find by_name name
+
+let create name =
+  {name = name}

channel.mli

@@ -0,0 +1,4 @@
+type t
+
+val create : string -> t
+val lookup : string -> t

client.ml

@@ -3,11 +3,33 @@ open Irc
 (* ==========================================
  * Client stuff
  *)
+type t = {outq: Command.t Queue.t;
+          unsent: string ref;
+          ibuf: string;
+          ibuf_len: int ref;
+          output_ready: unit -> unit;
+          handle_command: t -> Command.t -> unit;
+          nick: string ref;
+          username: string ref;
+          realname: string ref}
+
+
+let by_file_descr = Hashtbl.create 25
+let by_nick = Hashtbl.create 25
+
 let ibuf_max = 4096
 let max_outq = 50
 let obuf_max = 4096
 
-let shutdown ues g fd =
+let lookup nick =
+  Hashtbl.find by_nick nick
+
+let lookup_fd fd =
+  Hashtbl.find by_file_descr fd
+
+let close cli ues g fd =
+  Hashtbl.remove by_nick !(cli.nick);
+  Hashtbl.remove by_file_descr fd;
   Unix.close fd;
   Unixqueue.remove_resource ues g (Unixqueue.Wait_in fd);
   try
@@ -15,79 +37,106 @@ let shutdown ues g fd =
   with Not_found ->
     ()
 
-let write cli line =
+let write cli cmd =
   let was_empty = Queue.is_empty cli.outq in
-    Queue.add line cli.outq;
+    Queue.add cmd cli.outq;
     if was_empty then
       cli.output_ready ()
 
-let handle_close srv cli =
+let handle_close cli =
   ()
 
-let handle_command_login srv cli command =
+let handle_command cli command =
-  (* Handle a command during the login phase *)
+  ()
-  match command.command with
-    | "USER"
-    | "NICK" ->
-	()
-    | _ ->
-	print_endline "NO CAN DO SIR"
 
-let rec handle_input srv cli =
+let handle_command_login cli cmd =
+  (* Handle a command during the login phase *)
+  match (Command.as_tuple cmd) with
+    | (None, "USER", [username], Some realname) ->
+        cli.username := username;
+        cli.realname := Irc.truncate realname 40
+    | (None, "NICK", [nick], None) ->
+        cli.nick := nick
+    | _ ->
+        write cli (Command.create 
+                     ~sender:(Some !Irc.name)
+                     ~text:(Some "Register first.")
+                     "451" ["*"])
+
+let rec handle_input cli =
     match cli.ibuf with
       | "" ->
-	  ()
+          ()
       | ibuf ->
-	  let p = String.index ibuf '\n' in
+          let p = String.index ibuf '\n' in
-	  let s = String.sub ibuf 0 p in
+          let s = String.sub ibuf 0 p in
-	    if p >= !(cli.ibuf_len) then
+            if p >= !(cli.ibuf_len) then
-	      raise Not_found;
+              raise Not_found;
-	    cli.ibuf_len := !(cli.ibuf_len) - (p + 1);
+            cli.ibuf_len := !(cli.ibuf_len) - (p + 1);
-	    String.blit ibuf (p + 1) ibuf 0 !(cli.ibuf_len);
+            String.blit ibuf (p + 1) ibuf 0 !(cli.ibuf_len);
-	    let parsed = Irc.command_of_string s in
+            let parsed = Command.from_string s in
-	      cli.handle_command srv cli parsed;
+              cli.handle_command cli parsed;
-	      handle_input srv cli
+              handle_input cli
 
-let create_event_handler srv =
+let handle_event ues esys e =
-  fun ues esys e ->
+  match e with
-    match e with
+    | Unixqueue.Input_arrived (g, fd) ->
-      | Unixqueue.Input_arrived (g, fd) ->
+        let cli = lookup_fd fd in
-	  let cli = Server.get_client_by_file_descr srv fd in
+        let size = ibuf_max - !(cli.ibuf_len) in
-	  let size = ibuf_max - !(cli.ibuf_len) in
+        let len = Unix.read fd cli.ibuf !(cli.ibuf_len) size in
-	  let len = Unix.read fd cli.ibuf !(cli.ibuf_len) size in
+          if (len > 0) then
-	    if (len > 0) then
+            begin
-	      begin
+              cli.ibuf_len := !(cli.ibuf_len) + len;
-		cli.ibuf_len := !(cli.ibuf_len) + len;
+              try
-		try
+                handle_input cli
-		  handle_input srv cli
+              with Not_found ->
-		with Not_found ->
+                if (!(cli.ibuf_len) = ibuf_max) then
-		  if (!(cli.ibuf_len) = ibuf_max) then
+                  (* No newline found, and the buffer is full *)
-		    (* No newline found, and the buffer is full *)
+                  raise (Failure "Buffer overrun");
-		    raise (Failure "Buffer overrun");
+            end
-	      end
+          else
-	    else
+            close cli ues g fd
-	      shutdown ues g fd
+    | Unixqueue.Output_readiness (g, fd) ->
-      | Unixqueue.Output_readiness (g, fd) ->
+        (* XXX: Could be optimized to try and fill the output buffer *)
-	  print_endline "out"
+        let cli = lookup_fd fd in
-      | Unixqueue.Out_of_band (g, fd) ->
+        let buf =
-	  print_endline "oob"
+          if (!(cli.unsent) = "") then
-      | Unixqueue.Timeout (g, op) ->
+            let cmd = Queue.pop cli.outq in
-	  print_endline "timeout"
+              Command.as_string cmd
-      | Unixqueue.Signal ->
+          else
-	  print_endline "signal"
+            !(cli.unsent)
-      | Unixqueue.Extra exn ->
+        in
-	  print_endline "extra"
+        let n = Unix.single_write fd buf 0 (String.length buf) in
+          cli.unsent := Str.string_after buf n
+    | 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"
 
 
 let create ues g fd =
-  {outq = Queue.create ();
+  let cli =
-   unsent = ref "";
+    {outq = Queue.create ();
-   ibuf = String.create ibuf_max;
+     unsent = ref "";
-   ibuf_len = ref 0;
+     ibuf = String.create ibuf_max;
-   output_ready = 
+     ibuf_len = ref 0;
-      begin
+     output_ready = 
-	fun () -> Unixqueue.add_resource ues g (Unixqueue.Wait_out fd, -.1.0)
+	begin
-      end;
+          fun () -> Unixqueue.add_resource ues g (Unixqueue.Wait_out fd, -.1.0)
-   handle_command = handle_command_login;
+	end;
-   channels = []}
+     handle_command = handle_command_login;
+     nick = ref "";
+     username = ref "";
+     realname = ref ""}
+  in
+    Hashtbl.replace by_file_descr fd cli;
+    cli
 
+let set_nick cli nick =
+  Hashtbl.remove by_nick !(cli.nick);
+  Hashtbl.replace by_nick nick cli;
+  cli.nick := nick

client.mli

@@ -1,5 +1,8 @@
-val create : Unixqueue.event_system -> Unixqueue.group -> Unix.file_descr -> Irc.client
+type t
-val create_event_handler : Irc.server -> (Unixqueue.event_system -> Unixqueue.event Equeue.t -> Unixqueue.event -> unit)
-val write : Irc.client -> string list -> unit
 
+val create : Unixqueue.event_system -> Unixqueue.group -> Unix.file_descr -> t
+val lookup : string -> t
+val write : t -> Command.t -> unit
+
+val handle_event : Unixqueue.event_system -> Unixqueue.event Equeue.t -> Unixqueue.event -> unit
   

command.ml

@@ -0,0 +1,83 @@
+type t = {sender: string option;
+	  name: string;
+	  args: string list;
+	  text: string option}
+
+let create ?(sender=None) ?(text=None) name args =
+  {sender = sender;
+   name = name;
+   args = args;
+   text = text}
+
+let as_string cmd =
+  let ret = Buffer.create 120 in
+    (match cmd.sender with
+       | None -> 
+	   ()
+       | Some s ->
+	   Buffer.add_char ret ':';
+	   Buffer.add_string ret s;
+	   Buffer.add_char ret ' ');
+    Buffer.add_string ret cmd.name;
+    (match cmd.args with
+       | [] ->
+	   ()
+       | l ->
+	   Buffer.add_char ret ' ';
+	   Buffer.add_string ret (String.concat " " l));
+    (match cmd.text with
+       | None ->
+	   ()
+       | Some txt ->
+	   Buffer.add_string ret " :";
+	   Buffer.add_string ret txt);
+    Buffer.contents ret
+
+let extract_word s =
+  try
+    let pos = String.index s ' ' in
+      (Str.string_before s pos, Str.string_after s (pos + 1))
+  with Not_found ->
+    (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.. *)
+  let rec loop sender acc line =
+    let c = (if (line = "") then None else (Some line.[0])) in
+      match (c, acc) with
+     	| (None, cmd :: args) ->
+     	    (* End of line, no text part *)
+	    {sender = sender;
+	     name = cmd;
+	     args = args;
+	     text = None}
+	| (None, []) ->
+	    (* End of line, no text part, no args, no command *)
+	    raise (Failure "No command, eh?")
+	| (Some ':', []) ->
+	    (* First word, starts with ':' *)
+	    let (word, rest) = extract_word line in
+	      loop (Some (Str.string_after word 1)) acc rest
+	| (Some ':', cmd :: args) ->
+	    (* Not first word, starts with ':' *)
+	    {sender = sender;
+	     name = cmd;
+	     args = args;
+	     text = Some (Str.string_after line 1)}
+	| (Some _, _) ->
+	    (* Argument *)
+	    let (word, rest) = extract_word line in
+	      loop sender (acc @ [word]) rest
+  in
+    loop None [] line
+
+
+let as_tuple cmd =
+  (cmd.sender, cmd.name, cmd.args, cmd.text)
+
+let sender cmd = cmd.sender
+let name cmd = cmd.name
+let args cmd = cmd.args
+let text cmd = cmd.text

command.mli

@@ -0,0 +1,11 @@
+type t
+
+val create : ?sender:string option -> ?text:string option -> string -> string list -> t
+val from_string : string -> t
+val as_string : t -> string
+val as_tuple : t -> (string option * string * string list * string option)
+
+val sender : t -> string option
+val name : t -> string
+val args : t -> string list
+val text : t -> string option

irc.ml

@@ -1,19 +1,4 @@
-type command = {sender: string option;
+let name = ref "irc.test"
-		command: string;
-		args: string list;
-		text: string option}
-
-type server = {clients_by_name: (string, client) Hashtbl.t;
-	       clients_by_file_descr: (Unix.file_descr, client) Hashtbl.t;
-	       channels_by_name: (string, channel) Hashtbl.t}
-and client = {outq: string list Queue.t;
-	      unsent: string ref;
-	      ibuf: string;
-	      ibuf_len: int ref;
-	      output_ready: unit -> unit;
-	      handle_command: server -> client -> command -> unit;
-	      channels: channel list}
-and channel = {name: string}
 
 let newline_re = Pcre.regexp "\n\r?"
 let argsep_re = Pcre.regexp " :"
@@ -49,56 +34,9 @@ let uppercase_char c =
 let uppercase s = string_map uppercase_char s
 let lowercase s = string_map lowercase_char s
 
-let extract_word s =
+let truncate s len =
-  try
+  let slen = String.length s in
-    let pos = String.index s ' ' in
+    if len >= slen then
-      (Str.string_before s pos, Str.string_after s (pos + 1))
+      s
-  with Not_found ->
+    else
-    (s, "")
+      Str.string_before s (min slen len)
-
-let string_list_of_command cmd =
-  ([] @
-     (match cmd.sender with
-       | None -> []
-       | Some s -> [":" ^ s]) @
-     [cmd.command] @
-     cmd.args @
-     (match cmd.text with
-	| None -> []
-	| Some s -> [":" ^ s]))
-
-let string_of_command cmd =
-  String.concat " " (string_list_of_command cmd)
-
-let rec command_of_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.. *)
-  let rec loop sender acc line =
-    let c = (if (line = "") then None else (Some line.[0])) in
-      match (c, acc) with
-     	| (None, cmd :: args) ->
-     	    (* End of line, no text part *)
-	    {sender = sender;
-	     command = cmd;
-	     args = args;
-	     text = None}
-	| (None, []) ->
-	    (* End of line, no text part, no args, no command *)
-	    raise (Failure "No command, eh?")
-	| (Some ':', []) ->
-	    (* First word, starts with ':' *)
-	    let (word, rest) = extract_word line in
-	      loop (Some (Str.string_after word 1)) acc rest
-	| (Some ':', cmd :: args) ->
-	    (* Not first word, starts with ':' *)
-	    {sender = sender;
-	     command = cmd;
-	     args = args;
-	     text = Some (Str.string_after line 1)}
-	| (Some _, _) ->
-	    (* Argument *)
-	    let (word, rest) = extract_word line in
-	      loop sender (acc @ [word]) rest
-  in
-    loop None [] line

irc.mli

@@ -1,21 +1,4 @@
-type command = {sender: string option;
+val name : string ref
-		command: string;
-		args: string list;
-		text: string option}
-
-type server = {clients_by_name: (string, client) Hashtbl.t;
-	       clients_by_file_descr: (Unix.file_descr, client) Hashtbl.t;
-	       channels_by_name: (string, channel) Hashtbl.t}
-and client = {outq: string list Queue.t;
-	      unsent: string ref;
-	      ibuf: string;
-	      ibuf_len: int ref;
-	      output_ready: unit -> unit;
-	      handle_command: server -> client -> command -> unit;
-	      channels: channel list}
-and channel = {name: string}
-
 val uppercase : string -> string
 val lowercase : string -> string
-val command_of_string : string -> command
+val truncate : string -> int -> string
-val string_of_command : command -> string

ircd.ml

@@ -25,16 +25,13 @@ let establish_server ues connection_handler addr =
     Unixqueue.add_resource ues g (Unixqueue.Wait_in srv, -.1.0)
 
 let main () =
-  let srv = Server.create () in
-  let handle_event = Client.create_event_handler srv in
   let ues = Unixqueue.create_unix_event_system () in
   let g = Unixqueue.new_group ues in
   let handle_connection fd =
-    let cli = Client.create ues g fd in
+    ignore (Client.create ues g fd);
-      Hashtbl.replace srv.Irc.clients_by_file_descr fd cli;
+    Unixqueue.add_resource ues g (Unixqueue.Wait_in fd, -.1.0)
-      Unixqueue.add_resource ues g (Unixqueue.Wait_in fd, -.1.0);
   in
-    Unixqueue.add_handler ues g handle_event;
+    Unixqueue.add_handler ues g Client.handle_event;
     establish_server
       ues
       handle_connection

server.ml

@@ -1,18 +0,0 @@
-open Irc
-
-(* ==========================================
- * Server stuff
- *)
-let create () =
-  {clients_by_name = Hashtbl.create 25;
-   clients_by_file_descr = Hashtbl.create 25;
-   channels_by_name = Hashtbl.create 10}
-
-let get_client_by_name srv name =
-  Hashtbl.find srv.clients_by_name name
-
-let get_client_by_file_descr srv fd =
-  Hashtbl.find srv.clients_by_file_descr fd
-
-let get_channel_by_name srv name =
-  Hashtbl.find srv.channels_by_name name

tests.ml

@@ -5,12 +5,9 @@ open Irc
 
 let do_chat script () =
   let ircd_instance ues fd =
-    let srv = Server.create () in
-    let handle_event = Client.create_event_handler srv in
     let g = Unixqueue.new_group ues in
-    let cli = Client.create ues g fd in
+      ignore (Client.create ues g fd);
-      Hashtbl.replace srv.Irc.clients_by_file_descr fd cli;
+      Unixqueue.add_handler ues g Client.handle_event;
-      Unixqueue.add_handler ues g handle_event;
       Unixqueue.add_resource ues g (Unixqueue.Wait_in fd, -.1.0)
   in
     chat script ircd_instance
@@ -21,26 +18,20 @@ let unit_tests =
       "command_of_string" >:: 
 	(fun () ->
 	   assert_equal
-	     ~printer:string_of_command
+	     ~printer:Command.as_string
-	     {sender = None;
+	     (Command.create "NICK" ["name"])
-	      command = "NICK";
+	     (Command.from_string "NICK name");
-	      args = ["name"];
-	      text = None}
-	     (command_of_string "NICK name");
 	   assert_equal
-	     ~printer:string_of_command
+	     ~printer:Command.as_string
-	     {sender = Some "foo";
+	     (Command.create ~sender:(Some "foo") "NICK" ["name"])
-	      command = "NICK";
+	     (Command.from_string ":foo NICK name");
-	      args = ["name"];
-	      text = None}
-	     (command_of_string ":foo NICK name");
 	   assert_equal
-	     ~printer:string_of_command
+	     ~printer:Command.as_string
-	     {sender = Some "foo.bar";
+	     (Command.create 
-	      command = "PART";
+		~sender:(Some "foo.bar") 
-	      args = ["#foo"; "#bar"];
+		~text:(Some "ta ta") 
-	      text = Some "ta ta"}
+		"PART" ["#foo"; "#bar"])
-	     (command_of_string ":foo.bar PART #foo #bar :ta ta");
+	     (Command.from_string ":foo.bar PART #foo #bar :ta ta");
 	)
     ]