diff --git a/OMakefile b/OMakefile index faf8bfd..ba953a9 100644 --- a/OMakefile +++ b/OMakefile @@ -9,7 +9,7 @@ OCAMLCFLAGS += -g .DEFAULT: ircd -OCamlProgram(ircd, ircd irc command client channel) +OCamlProgram(ircd, ircd irc command iobuf client channel) section OCAMLPACKS[] += @@ -21,7 +21,7 @@ section tests.cmo: tests$(EXT_OBJ): - OCamlProgram(tests, tests chat irc command client channel) + OCamlProgram(tests, tests chat irc command iobuf client channel) .PHONY: clean clean: diff --git a/client.ml b/client.ml index 726df3d..42fbd63 100644 --- a/client.ml +++ b/client.ml @@ -1,17 +1,16 @@ 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) ref; +type t = {iobuf: Iobuf.t; nick: string ref; - username: string ref; - realname: string ref} + username: string; + realname: string} + +exception Error of Command.t let modes = "l" @@ -20,15 +19,8 @@ let dbg msg a = prerr_endline msg; a 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 lookup nick = - Hashtbl.find by_nick nick - -let lookup_fd fd = - Hashtbl.find by_file_descr fd +let error num args text = + Error (Command.create (Some !(Irc.name)) num args (Some text)) let close cli ues g fd = Hashtbl.remove by_nick !(cli.nick); @@ -41,134 +33,71 @@ let close cli ues g fd = () let write cli cmd = - let was_empty = Queue.is_empty cli.outq in - Queue.add cmd cli.outq; - if (was_empty && (!(cli.unsent) = "")) then - cli.output_ready () + Iobuf.write cli.iobuf cmd -let handle_close cli = - () +let reply cli num text = + write cli (Command.create + (Some !(Irc.name)) num [!(cli.nick)] (Some text)) -let handle_command cli cmd = +let handle_command cli iobuf cmd = write cli cmd -let handle_command_login cli cmd = - (* Handle a command during the login phase *) - begin - 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 - (Some !Irc.name) "451" ["*"] (Some "Register first.")) - end; - match (!(cli.username), !(cli.nick)) with - | ("", _) - | (_, "") -> - () - | (_, nick) -> - cli.handle_command := handle_command; - let command name text = - write cli (Command.create - (Some !(Irc.name)) - name - [nick] - (Some text)) - in - command "001" "Welcome to IRC."; - command "002" ("I am " ^ !(Irc.name) ^ - " running version " ^ Irc.version); - command "003" "This server was created sometime"; - command "004" (!(Irc.name) ^ - " " ^ Irc.version ^ - " " ^ modes ^ - " " ^ Channel.modes) - -let crlf = Str.regexp "\r?\n" - -let handle_input cli = - let buf = Str.string_before cli.ibuf !(cli.ibuf_len) in - let lines = Str.split_delim crlf buf in - let rec loop l = - match l with - | [] -> - () - | [leftover] -> - cli.ibuf_len := (String.length leftover); - String.blit leftover 0 cli.ibuf 0 !(cli.ibuf_len) - | line :: tl -> - let parsed = Command.from_string line in - !(cli.handle_command) cli parsed; - loop tl - in - loop lines - -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) ^ "\r\n" - else - !(cli.unsent) - in - let buflen = String.length buf in - let n = Unix.single_write fd buf 0 buflen in - if n < buflen then - cli.unsent := Str.string_after buf n - else if Queue.is_empty cli.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" - - -let create ues g fd = - 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 = ref handle_command_login; - nick = ref ""; - username = ref ""; - realname = ref ""} - in - Hashtbl.replace by_file_descr fd cli; - cli - let set_nick cli nick = + if Hashtbl.mem by_nick nick then + raise (error "433" [nick] "Nickname in use"); Hashtbl.remove by_nick !(cli.nick); Hashtbl.replace by_nick nick cli; cli.nick := nick + +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') + | _ -> + Iobuf.write iobuf (Command.create + (Some !(Irc.name)) + "451" ["*"] + (Some "Register first.")); + (nick', username', realname', password') + in + let welcome cli = + try + set_nick cli !(cli.nick); + reply cli "001" "Welcome to IRC."; + reply cli "002" ("I am " ^ !(Irc.name) ^ + " Running version " ^ Irc.version); + reply cli "003" "This server was created sometime"; + reply cli "004" (!(Irc.name) ^ + " " ^ Irc.version ^ + " " ^ modes ^ + " " ^ Channel.modes); + Iobuf.rebind iobuf (handle_command cli) + with Error cmd -> + Iobuf.write iobuf cmd + in + match acc with + | (Some nick, Some username, Some realname, None) -> + welcome {iobuf = iobuf; + nick = ref nick; + username = username; + realname = realname} + | (Some nick, Some username, Some realname, Some password) -> + Iobuf.write iobuf (Command.create + (Some !(Irc.name)) + "NOTICE" ["AUTH"] + (Some "*** Authentication unimplemented")); + welcome {iobuf = iobuf; + nick = ref nick; + username = username; + realname = realname} + | _ -> + Iobuf.rebind iobuf (handle_command_prereg acc) + +let create_command_handler () = + handle_command_prereg (None, None, None, None) diff --git a/client.mli b/client.mli index 823ef0d..30cc38f 100644 --- a/client.mli +++ b/client.mli @@ -1,8 +1,5 @@ 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 +val create_command_handler : unit -> Iobuf.t -> Command.t -> unit diff --git a/command.ml b/command.ml index 24808c5..4fda1c1 100644 --- a/command.ml +++ b/command.ml @@ -1,33 +1,27 @@ -type t = {sender: string option; - name: string; - args: string list; - text: string option} +type t = string option * string * string list * string option let create sender name args text = - {sender = sender; - name = name; - args = args; - text = text} + (sender, name, args, text) let anon = create None -let as_string cmd = +let as_string (sender, name, args, text) = let ret = Buffer.create 120 in - (match cmd.sender with + (match 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 + Buffer.add_string ret name; + (match args with | [] -> () | l -> Buffer.add_char ret ' '; Buffer.add_string ret (String.concat " " l)); - (match cmd.text with + (match text with | None -> () | Some txt -> @@ -49,12 +43,9 @@ let rec from_string line = let rec loop sender acc line = let c = (if (line = "") then None else (Some line.[0])) in match (c, acc) with - | (None, cmd :: args) -> + | (None, name :: args) -> (* End of line, no text part *) - {sender = sender; - name = cmd; - args = args; - text = None} + create sender name args None | (None, []) -> (* End of line, no text part, no args, no command *) raise (Failure "No command, eh?") @@ -62,12 +53,9 @@ let rec from_string line = (* First word, starts with ':' *) let (word, rest) = extract_word line in loop (Some (Str.string_after word 1)) acc rest - | (Some ':', cmd :: args) -> + | (Some ':', name :: args) -> (* Not first word, starts with ':' *) - {sender = sender; - name = cmd; - args = args; - text = Some (Str.string_after line 1)} + create sender name args (Some (Str.string_after line 1)) | (Some _, _) -> (* Argument *) let (word, rest) = extract_word line in @@ -76,10 +64,9 @@ let rec from_string line = loop None [] line -let as_tuple cmd = - (cmd.sender, cmd.name, cmd.args, cmd.text) +let as_tuple cmd = cmd -let sender cmd = cmd.sender -let name cmd = cmd.name -let args cmd = cmd.args -let text cmd = cmd.text +let sender (sender, name, args, text) = sender +let name (sender, name, args, text) = name +let args (sender, name, args, text) = args +let text (sender, name, args, text) = text diff --git a/iobuf.ml b/iobuf.ml new file mode 100644 index 0000000..3868bfd --- /dev/null +++ b/iobuf.ml @@ -0,0 +1,121 @@ +(* ========================================== + * I/O buf stuff + *) +type t = {ues: Unixqueue.event_system; + grp: Unixqueue.group; + fd: Unix.file_descr; + outq: Command.t Queue.t; + unsent: string ref; + ibuf: string; + ibuf_len: int ref; + handle_command: t -> Command.t -> unit} + +let ibuf_max = 4096 +let max_outq = 50 +let obuf_max = 4096 + +let by_file_descr = Hashtbl.create 25 + +let bind ues grp fd handle_command = + let (outq, unsent, ibuf, ibuf_len) = + try + let old = Hashtbl.find by_file_descr fd in + (old.outq, old.unsent, old.ibuf, old.ibuf_len) + with Not_found -> + (Queue.create (), ref "", String.create ibuf_max, ref 0) + in + let iobuf = {ues = ues; + grp = grp; + fd = fd; + outq = outq; + unsent = unsent; + ibuf = ibuf; + ibuf_len = ibuf_len; + handle_command = handle_command} + in + Hashtbl.replace by_file_descr fd iobuf; + Unixqueue.add_resource ues grp (Unixqueue.Wait_in fd, -.1.0) + +let rebind t handle_command = + bind t.ues t.grp t.fd handle_command + +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) + +let close iobuf = + 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 crlf = Str.regexp "\r?\n" + +let handle_input iobuf = + let buf = Str.string_before iobuf.ibuf !(iobuf.ibuf_len) in + let lines = Str.split_delim crlf buf in + let rec loop l = + match l with + | [] -> + () + | [leftover] -> + iobuf.ibuf_len := (String.length leftover); + String.blit leftover 0 iobuf.ibuf 0 !(iobuf.ibuf_len) + | line :: tl -> + let parsed = Command.from_string line in + iobuf.handle_command iobuf parsed; + loop tl + 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 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) -> + (* 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 + (Command.as_string cmd) ^ "\r\n" + else + !(iobuf.unsent) + 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 + 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" + +let add_event_handler ues g = + Unixqueue.add_handler ues g handle_event diff --git a/iobuf.mli b/iobuf.mli new file mode 100644 index 0000000..86764db --- /dev/null +++ b/iobuf.mli @@ -0,0 +1,8 @@ +type t + +val write : t -> Command.t -> unit +val bind : Unixqueue.event_system -> Unixqueue.group -> Unix.file_descr -> (t -> Command.t -> unit) -> unit +val rebind: t -> (t -> Command.t -> unit) -> unit +val close: t -> unit +val add_event_handler : Unixqueue.event_system -> Unixqueue.group -> unit + diff --git a/ircd.ml b/ircd.ml index d7f6314..35e9729 100644 --- a/ircd.ml +++ b/ircd.ml @@ -28,10 +28,9 @@ let main () = let ues = Unixqueue.create_unix_event_system () in let g = Unixqueue.new_group ues in let handle_connection fd = - ignore (Client.create ues g fd); - Unixqueue.add_resource ues g (Unixqueue.Wait_in fd, -.1.0) + Iobuf.bind ues g fd (Client.create_command_handler ()) in - Unixqueue.add_handler ues g Client.handle_event; + Iobuf.add_event_handler ues g; establish_server ues handle_connection diff --git a/tests.ml b/tests.ml index 4b511bb..f1bc373 100644 --- a/tests.ml +++ b/tests.ml @@ -6,9 +6,8 @@ open Irc let do_chat script () = let ircd_instance ues fd = let g = Unixqueue.new_group ues in - 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) + Iobuf.add_event_handler ues g; + Iobuf.bind ues g fd (Client.create_command_handler ()) in chat script ircd_instance