diff --git a/OMakefile b/OMakefile index 7d3296b..5e42126 100644 --- a/OMakefile +++ b/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: diff --git a/channel.ml b/channel.ml new file mode 100644 index 0000000..b3dffcb --- /dev/null +++ b/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} diff --git a/channel.mli b/channel.mli new file mode 100644 index 0000000..449b489 --- /dev/null +++ b/channel.mli @@ -0,0 +1,4 @@ +type t + +val create : string -> t +val lookup : string -> t diff --git a/client.ml b/client.ml index d7a1d72..558be93 100644 --- a/client.ml +++ b/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 = - (* Handle a command during the login phase *) - match command.command with - | "USER" - | "NICK" -> - () - | _ -> - print_endline "NO CAN DO SIR" +let handle_command cli command = + () -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 s = String.sub ibuf 0 p in - if p >= !(cli.ibuf_len) then - raise Not_found; - cli.ibuf_len := !(cli.ibuf_len) - (p + 1); - String.blit ibuf (p + 1) ibuf 0 !(cli.ibuf_len); - let parsed = Irc.command_of_string s in - cli.handle_command srv cli parsed; - handle_input srv cli + let p = String.index ibuf '\n' in + let s = String.sub ibuf 0 p in + if p >= !(cli.ibuf_len) then + raise Not_found; + cli.ibuf_len := !(cli.ibuf_len) - (p + 1); + String.blit ibuf (p + 1) ibuf 0 !(cli.ibuf_len); + let parsed = Command.from_string s in + cli.handle_command cli parsed; + handle_input cli -let create_event_handler srv = - fun ues esys e -> - match e with - | Unixqueue.Input_arrived (g, fd) -> - let cli = Server.get_client_by_file_descr srv fd in - let size = ibuf_max - !(cli.ibuf_len) in - let len = Unix.read fd cli.ibuf !(cli.ibuf_len) size in - if (len > 0) then - begin - cli.ibuf_len := !(cli.ibuf_len) + len; - try - handle_input srv cli - with Not_found -> - if (!(cli.ibuf_len) = ibuf_max) then - (* No newline found, and the buffer is full *) - raise (Failure "Buffer overrun"); - end - else - shutdown ues g fd - | Unixqueue.Output_readiness (g, fd) -> - print_endline "out" - | 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 handle_event ues esys e = + match e with + | Unixqueue.Input_arrived (g, fd) -> + let cli = lookup_fd fd in + let size = ibuf_max - !(cli.ibuf_len) in + let len = Unix.read fd cli.ibuf !(cli.ibuf_len) size in + if (len > 0) then + begin + cli.ibuf_len := !(cli.ibuf_len) + len; + try + handle_input cli + with Not_found -> + if (!(cli.ibuf_len) = ibuf_max) then + (* No newline found, and the buffer is full *) + raise (Failure "Buffer overrun"); + end + else + close cli ues g fd + | Unixqueue.Output_readiness (g, fd) -> + (* XXX: Could be optimized to try and fill the output buffer *) + let cli = lookup_fd fd in + let buf = + if (!(cli.unsent) = "") then + let cmd = Queue.pop cli.outq in + Command.as_string cmd + else + !(cli.unsent) + in + 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 (); - unsent = ref ""; - ibuf = String.create ibuf_max; - ibuf_len = ref 0; - output_ready = - begin - fun () -> Unixqueue.add_resource ues g (Unixqueue.Wait_out fd, -.1.0) - end; - handle_command = handle_command_login; - channels = []} + let cli = + {outq = Queue.create (); + unsent = ref ""; + ibuf = String.create ibuf_max; + ibuf_len = ref 0; + output_ready = + begin + fun () -> Unixqueue.add_resource ues g (Unixqueue.Wait_out fd, -.1.0) + end; + 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 diff --git a/client.mli b/client.mli index cd3fc45..823ef0d 100644 --- a/client.mli +++ b/client.mli @@ -1,5 +1,8 @@ -val create : Unixqueue.event_system -> Unixqueue.group -> Unix.file_descr -> Irc.client -val create_event_handler : Irc.server -> (Unixqueue.event_system -> Unixqueue.event Equeue.t -> Unixqueue.event -> unit) -val write : Irc.client -> string list -> unit +type t +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 diff --git a/command.ml b/command.ml new file mode 100644 index 0000000..cbaaf5c --- /dev/null +++ b/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 diff --git a/command.mli b/command.mli new file mode 100644 index 0000000..736db51 --- /dev/null +++ b/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 diff --git a/irc.ml b/irc.ml index 3916d6f..50308b7 100644 --- a/irc.ml +++ b/irc.ml @@ -1,19 +1,4 @@ -type command = {sender: string option; - 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 name = ref "irc.test" 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 = - try - let pos = String.index s ' ' in - (Str.string_before s pos, Str.string_after s (pos + 1)) - with Not_found -> - (s, "") - -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 +let truncate s len = + let slen = String.length s in + if len >= slen then + s + else + Str.string_before s (min slen len) diff --git a/irc.mli b/irc.mli index 8350446..76e5329 100644 --- a/irc.mli +++ b/irc.mli @@ -1,21 +1,4 @@ -type command = {sender: string option; - 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 name : string ref val uppercase : string -> string val lowercase : string -> string -val command_of_string : string -> command -val string_of_command : command -> string +val truncate : string -> int -> string diff --git a/ircd.ml b/ircd.ml index d8ce109..d7f6314 100644 --- a/ircd.ml +++ b/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 - Hashtbl.replace srv.Irc.clients_by_file_descr fd cli; - Unixqueue.add_resource ues g (Unixqueue.Wait_in fd, -.1.0); + ignore (Client.create ues g fd); + 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 diff --git a/server.ml b/server.ml deleted file mode 100644 index 8b3fb77..0000000 --- a/server.ml +++ /dev/null @@ -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 diff --git a/tests.ml b/tests.ml index 0205884..43523fe 100644 --- a/tests.ml +++ b/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 - Hashtbl.replace srv.Irc.clients_by_file_descr fd cli; - Unixqueue.add_handler ues g handle_event; + ignore (Client.create ues g fd); + Unixqueue.add_handler ues g Client.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 - {sender = None; - command = "NICK"; - args = ["name"]; - text = None} - (command_of_string "NICK name"); + ~printer:Command.as_string + (Command.create "NICK" ["name"]) + (Command.from_string "NICK name"); assert_equal - ~printer:string_of_command - {sender = Some "foo"; - command = "NICK"; - args = ["name"]; - text = None} - (command_of_string ":foo NICK name"); + ~printer:Command.as_string + (Command.create ~sender:(Some "foo") "NICK" ["name"]) + (Command.from_string ":foo NICK name"); assert_equal - ~printer:string_of_command - {sender = Some "foo.bar"; - command = "PART"; - args = ["#foo"; "#bar"]; - text = Some "ta ta"} - (command_of_string ":foo.bar PART #foo #bar :ta ta"); + ~printer:Command.as_string + (Command.create + ~sender:(Some "foo.bar") + ~text:(Some "ta ta") + "PART" ["#foo"; "#bar"]) + (Command.from_string ":foo.bar PART #foo #bar :ta ta"); ) ]