Test 1 working, but now there are some obuf overrun problems

This commit is contained in:
Neale Pickett 2008-02-08 18:11:49 -07:00
parent 65720b5406
commit eb07c79700
4 changed files with 146 additions and 125 deletions

123
chat.ml
View File

@ -5,7 +5,7 @@ type chat_event =
| Recv of string | Recv of string
exception Chat_match of (chat_event * chat_event) exception Chat_match of (chat_event * chat_event)
exception Chat_failure of string exception Chat_timeout of chat_event
let string_of_chat_event e = let string_of_chat_event e =
match e with match e with
@ -14,7 +14,7 @@ let string_of_chat_event e =
| Recv str -> | Recv str ->
("Recv(\"" ^ (String.escaped str) ^ "\")") ("Recv(\"" ^ (String.escaped str) ^ "\")")
(** Return true if str starts with substr *) (** Return true if str starts with substr *)
let startswith str substr = let startswith str substr =
let l = String.length substr in let l = String.length substr in
if l > String.length str then if l > String.length str then
@ -39,82 +39,57 @@ let read_fd fd =
class chat_handler chatscript (ues : unix_event_system) fd = class chat_handler chatscript (ues : unix_event_system) fd =
object (self) object (self)
inherit Connection.connection ues fd
val mutable script = chatscript val mutable script = chatscript
val g = ues#new_group () val inbuf = Buffer.create 4096
initializer initializer
ues#add_handler g self#handler; self#run_script ();
self#setup () self#pulse (Send "") ()
method setup () =
method pulse hd () =
if (List.hd script = hd) then
raise (Chat_timeout hd)
else
ues#once g 2.0 (self#pulse (List.hd script))
method run_script () =
match script with match script with
| [] -> | [] ->
Unix.close fd; Unix.close fd;
ues#clear g ues#clear g
| Send _ :: _ -> | Send buf :: tl ->
ues#add_resource g (Wait_out fd, -.1.0); self#write buf;
begin script <- tl;
try self#run_script ()
ues#remove_resource g (Wait_in fd) | Recv buf :: tl ->
with Not_found -> let buf_len = String.length buf in
() let inbuf_str = Buffer.contents inbuf in
end if (Buffer.length inbuf >= buf_len) then
| Recv _ :: _ -> if startswith inbuf_str buf then
ues#add_resource g (Wait_in fd, -.1.0); begin
begin script <- tl;
try Buffer.clear inbuf;
ues#remove_resource g (Wait_out fd) Buffer.add_substring
with Not_found -> inbuf
() inbuf_str
end buf_len
((String.length inbuf_str) - buf_len);
self#run_script ()
method handler ues' (esys : event Equeue.t) e = end
assert (ues = ues'); else
match e with raise (Chat_match (Recv inbuf_str,
| Input_arrived (g, fd) -> Recv buf))
self#handle_input fd
| Output_readiness (g, fd) ->
self#handle_output fd
| _ ->
raise Equeue.Reject
method handle_input fd =
let buf = read_fd fd in
match script with
| Recv str :: tl ->
if (buf = str) then
begin
script <- tl;
self#setup()
end
else if startswith buf str then
begin
script <- [Recv (string_after buf (String.length str))] @ tl;
self#setup()
end
else else
raise (Chat_match ((Recv str), (Recv buf))) ()
| x :: tl ->
raise (Chat_match (x, (Recv buf)))
| [] ->
raise (Chat_match ((Recv ""), (Recv buf)))
method handle_output fd = method handle_input data =
match script with Buffer.add_string inbuf data;
| Send str :: tl -> self#run_script ()
let slen = String.length str in
let n = Unix.single_write fd str 0 slen in
if (n <> slen) then
script <- [Send (string_after str n)] @ tl
else
script <- tl;
self#setup()
| x :: tl ->
raise (Chat_match (x, (Send "")))
| [] ->
raise (Chat_match ((Recv ""), (Send "")))
end end
@ -133,9 +108,13 @@ let chat script proc =
let _ = new chat_handler script ues b in let _ = new chat_handler script ues b in
try try
Unixqueue.run ues Unixqueue.run ues
with Chat_match (got, expected) -> with
raise (Chat_failure ("Chat_match; got " ^ | Chat_match (got, expected) ->
(string_of_chat_event got) ^ raise (Failure ("Chat_match; got " ^
", expected " ^ (string_of_chat_event got) ^
(string_of_chat_event expected))) ", expected " ^
(string_of_chat_event expected)))
| Chat_timeout evt ->
raise (Failure ("Chat_timeout waiting for " ^
(string_of_chat_event evt)))

View File

@ -8,8 +8,14 @@ exception Buffer_overrun
line has been read. If the line is longer than the size of the line has been read. If the line is longer than the size of the
input queue, you get an Input_buffer_overrun exception. input queue, you get an Input_buffer_overrun exception.
Output could be further memory-optimized by instead storing a list
of strings, which would have a nice memory utilization if you're
frequently sending the same string out to multiple connections (like
with a chat server). However, I don't care that much.
You can inherit this and define appropriate [handle_*] methods. You can inherit this and define appropriate [handle_*] methods.
A [write] method is provided for your convenience. A [write] method is provided for your convenience.
*) *)
class connection class connection
(ues : unix_event_system) (ues : unix_event_system)
@ -17,25 +23,25 @@ class connection
?(output_max = 1024) ?(output_max = 1024)
fd = fd =
object (self) object (self)
val g = ues#new_group () val g = ues#new_group ()
val mutable debug = false val mutable debug = false
val obuf = String.create output_max val obuf = String.create output_max
val mutable obuf_len = 0 val mutable obuf_len = 0
val ibuf = String.create input_max
val mutable ibuf_len = 0 val input_timeout = -.1.0
val output_timeout = -.1.0
initializer initializer
ues#add_handler g self#handle_event; ues#add_handler g self#handle_event;
ues#add_resource g (Wait_in fd, -.1.0) ues#add_resource g (Wait_in fd, input_timeout)
method debug v = method debug v =
debug <- v debug <- v
method log msg = method log msg =
if debug then if debug then
prerr_endline msg print_endline msg
method write data = method write data =
let data_len = String.length data in let data_len = String.length data in
@ -43,7 +49,7 @@ object (self)
raise Buffer_overrun; raise Buffer_overrun;
String.blit data 0 obuf obuf_len data_len; String.blit data 0 obuf obuf_len data_len;
obuf_len <- obuf_len + data_len; obuf_len <- obuf_len + data_len;
ues#add_resource g (Wait_out fd, -.1.0) ues#add_resource g (Wait_out fd, output_timeout)
method handle_event ues esys e = method handle_event ues esys e =
@ -76,37 +82,11 @@ object (self)
String.blit obuf n obuf 0 (obuf_len) String.blit obuf n obuf 0 (obuf_len)
end end
(** Split ibuf on newline, feeding each split into self#handle_input.
Does not send the trailing newline. You can add it back if you want.
*)
method split_handle_input () =
match ibuf with
| "" ->
()
| ibuf ->
let p = String.index ibuf '\n' in
let s = String.sub ibuf 0 p in
if p >= ibuf_len then
raise Not_found;
ibuf_len <- ibuf_len - (p + 1);
String.blit ibuf (p + 1) ibuf 0 ibuf_len;
self#handle_input s;
self#split_handle_input ()
method input_ready fd = method input_ready fd =
let size = input_max - ibuf_len in let data = String.create input_max in
let len = Unix.read fd ibuf ibuf_len size in let len = Unix.read fd data 0 input_max in
if (len > 0) then if (len > 0) then
begin self#handle_input (String.sub data 0 len)
ibuf_len <- ibuf_len + len;
try
self#split_handle_input ()
with Not_found ->
if (ibuf_len = output_max) then
(* No newline found, and the buffer is full *)
raise Buffer_overrun;
end
else else
begin begin
self#handle_close (); self#handle_close ();
@ -115,10 +95,9 @@ object (self)
end end
method handle_input data = method handle_input data =
self#log ("<-- [" ^ (String.escaped data) ^ "]"); self#log ("<-- [" ^ (String.escaped data) ^ "]");
raise Equeue.Reject
method handle_oob fd = method handle_oob fd =
self#log "Unhandled OOB"; self#log "Unhandled OOB";
@ -142,6 +121,63 @@ object (self)
end end
class line_connection
(ues : unix_event_system)
?(input_max = 1024)
?(output_max = 1024)
fd =
object (self)
inherit connection ues ~input_max ~output_max fd
val ibuf = String.create input_max
val mutable ibuf_len = 0
(** Split ibuf on newline, feeding each split into self#handle_input.
Does not send the trailing newline. You can add it back if you want.
*)
method split_handle_input () =
match ibuf with
| "" ->
()
| ibuf ->
let p = String.index ibuf '\n' in
let s = String.sub ibuf 0 p in
if p >= ibuf_len then
raise Not_found;
ibuf_len <- ibuf_len - (p + 1);
String.blit ibuf (p + 1) ibuf 0 ibuf_len;
self#handle_line s;
self#split_handle_input ()
method input_ready fd =
let size = input_max - ibuf_len in
let len = Unix.read fd ibuf ibuf_len size in
if (len > 0) then
begin
ibuf_len <- ibuf_len + len;
prerr_endline ("ibuf_len" ^ (string_of_int ibuf_len));
try
self#split_handle_input ()
with Not_found ->
if (ibuf_len = output_max) then
(* No newline found, and the buffer is full *)
raise Buffer_overrun;
end
else
begin
self#handle_close ();
Unix.close fd;
ues#clear g;
end
method handle_input data =
raise (Failure "handle_input should never be called for line_connection objects")
method handle_line line =
self#log ("<-- " ^ (String.escaped line))
end
(** Establish a server on the given address. (** Establish a server on the given address.

16
ircd.ml
View File

@ -2,7 +2,18 @@ open Unixqueue
class ircd_connection (ues : unix_event_system) fd = class ircd_connection (ues : unix_event_system) fd =
object (self) object (self)
inherit Connection.connection ues fd inherit Connection.line_connection ues fd
method handle_line line =
let parts = Pcre.split ~pat:" " line in
match parts with
| ["NICK"; nick] ->
self#log ("Set nickname to " ^ nick);
self#write ":testserver.test NOTICE nick :*** Hi there.\n";
self#write "PING :12345\n";
| _ ->
self#log ("Unknown: " ^ line)
end end
@ -19,6 +30,3 @@ let main () =
(Unix.ADDR_INET (Unix.inet_addr_any, 7777)); (Unix.ADDR_INET (Unix.inet_addr_any, 7777));
ues#run () ues#run ()
let _ =
main ()

View File

@ -3,21 +3,20 @@ open OUnit
open Chat open Chat
let do_chat script () = let do_chat script () =
let irc_instance ues fd = let ircd_instance ues fd =
let irc = new Irc.irc ues in let irc = new Ircd.ircd_connection ues fd in
irc#set_fd fd "nick" "gecos";
irc#debug true irc#debug true
in in
chat script irc_instance chat script ircd_instance
let normal_tests = let normal_tests =
let login_script = let login_script =
[ [
Recv "USER nick +iw nick :gecos\n"; Send "USER nick +iw nick :gecos\n";
Recv "NICK nick\n"; Send "NICK nick\n";
Send ":testserver.test NOTICE nick :*** Hi there.\n"; Recv ":testserver.test NOTICE nick :*** Hi there.\n";
Send "PING :12345\n"; Recv "PING :12345\n";
Recv "PONG :12345\n"; Send "PONG :12345\n";
] ]
in in
"Normal tests" >::: "Normal tests" >:::
@ -28,8 +27,7 @@ let normal_tests =
"Full connection" >:: "Full connection" >::
(do_chat (do_chat
([Send ":testserver.test NOTICE AUTH :*** Doing some pointless ident junk...\n"] @ (login_script @
login_script @
[ [
Send ":testserver.test 001 nick :Welcome to the test script\n"; Send ":testserver.test 001 nick :Welcome to the test script\n";
Send ":testserver.test 002 nick :Your host is testserver.test\n"; Send ":testserver.test 002 nick :Your host is testserver.test\n";