commit eccaa1b4ffa52a6477ea1dd55e43798236e58da6
Author: Neale Pickett <neale@lanl.gov>
Date:   Fri Feb 8 15:38:31 2008 -0700

    Accepting connections and line-buffering input

diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..17e1ed4
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,34 @@
+OCAML_PACKAGES := -package equeue -package pcre
+
+TARGETS = ircd
+
+OCAMLOPTS = -g
+OCAMLC = ocamlfind c $(OCAMLOPTS)
+
+all: $(TARGETS)
+
+ircd: connection.cmo ircd.cmo
+
+.PHONY: test
+test: tests
+	./tests
+
+##
+## Generic ways to do things
+##
+%.cmo : %.ml
+	$(OCAMLC) -c $^ $(OCAML_PACKAGES)
+
+%: %.cmo
+	$(OCAMLC) -o $@ $(filter-out $<, $^) $< $(OCAML_PACKAGES) -linkpkg
+
+##
+## 
+##
+include .deps
+.deps: *.ml
+	ocamldep $^ > $@
+
+.PHONY: clean
+clean:
+	rm -f $(TARGETS) *.cm? *.o
diff --git a/README b/README
new file mode 100644
index 0000000..0a63d99
--- /dev/null
+++ b/README
@@ -0,0 +1,17 @@
+Pretty Good IRC Daemon
+======================
+
+This is a feature-stripped IRC daemon similar to the now-defunct iacd.
+It provides an additional set of commands to allow clients to intercept
+all channel activity.  This allows a whole new range of possibilites for
+bots: including something as simple as rot13-encoding all channel
+discussions, to something as complex as a full MUD or MOO.
+
+
+Downloading
+-----------
+
+If you can read this, I forgot to update the README!  Please mail
+neale@woozle.org and I'll publish a URL for a download.
+
+
diff --git a/chat.ml b/chat.ml
new file mode 100644
index 0000000..5cc16fc
--- /dev/null
+++ b/chat.ml
@@ -0,0 +1,141 @@
+open Unixqueue
+
+type chat_event =
+  | Send of string
+  | Recv of string
+
+exception Chat_match of (chat_event * chat_event)
+exception Chat_failure of string
+
+let string_of_chat_event e =
+  match e with
+    | Send str ->
+	("Send(\"" ^ (String.escaped str) ^ "\")")
+    | Recv str ->
+	("Recv(\"" ^ (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 (ues : unix_event_system) fd =
+object (self)
+  val mutable script = chatscript
+  val g = ues#new_group ()
+
+  initializer
+    ues#add_handler g self#handler;
+    self#setup ()
+
+  method setup () =
+    match script with
+      | [] ->
+	  Unix.close fd;
+	  ues#clear g
+      | Send _ :: _ ->
+	  ues#add_resource g (Wait_out fd, -.1.0);
+	  begin
+	    try
+	      ues#remove_resource g (Wait_in fd)
+	    with Not_found ->
+	      ()
+	  end
+      | Recv _ :: _ ->
+	  ues#add_resource g (Wait_in fd, -.1.0);
+	  begin
+	    try
+	      ues#remove_resource g (Wait_out fd)
+	    with Not_found ->
+	      ()
+	  end
+
+
+  method handler ues' (esys : event Equeue.t) e =
+    assert (ues = ues');
+    match e with
+      | Input_arrived (g, fd) ->
+	  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
+	      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 =
+    match script with
+      | Send str :: tl ->
+	  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
+
+
+(** 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 script proc =
+  let ues = new unix_event_system () in
+  let a,b = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+  let _ = proc ues a in
+  let _ = new chat_handler script ues b in
+    try
+      Unixqueue.run ues
+    with Chat_match (got, expected) ->
+      raise (Chat_failure ("Chat_match; got " ^
+			     (string_of_chat_event got) ^
+			     ", expected " ^
+			     (string_of_chat_event expected)))
+
diff --git a/connection.ml b/connection.ml
new file mode 100644
index 0000000..cca8463
--- /dev/null
+++ b/connection.ml
@@ -0,0 +1,168 @@
+open Unixqueue
+
+exception Buffer_overrun
+
+(** Generic equeue connection class.
+
+    Input is line-buffered: handle_data is only called once a complete
+    line has been read.  If the line is longer than the size of the
+    input queue, you get an Input_buffer_overrun exception.
+
+    You can inherit this and define appropriate [handle_*] methods.
+    A [write] method is provided for your convenience.
+    *)
+class connection
+  (ues : unix_event_system)
+  ?(input_max = 1024)
+  ?(output_max = 1024)
+  fd =
+object (self)
+
+  val g = ues#new_group ()
+  val mutable debug = false
+
+  val obuf = String.create output_max
+  val mutable obuf_len = 0
+  val ibuf = String.create input_max
+  val mutable ibuf_len = 0
+
+  initializer
+    ues#add_handler g self#handle_event;
+    ues#add_resource g (Wait_in fd, -.1.0)
+
+  method debug v =
+    debug <- v
+
+  method log msg =
+    if debug then
+      prerr_endline msg
+
+  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, -.1.0)
+
+
+  method handle_event ues esys e =
+    match e with
+      | Input_arrived (g, fd) ->
+	  self#input_ready fd
+      | Output_readiness (g, fd) ->
+	  self#output_ready fd
+      | Out_of_band (g, fd) ->
+	  self#handle_oob fd
+      | Timeout (g, op) ->
+	  self#handle_timeout op
+      | Signal ->
+	  self#handle_signal ()
+      | Extra exn ->
+	  self#handle_extra exn
+
+  method output_ready 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
+    
+  (** 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 =
+    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;
+	  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 =
+    self#log ("<-- [" ^ (String.escaped data) ^ "]");
+
+  method handle_oob fd =
+    self#log "Unhandled OOB";
+    raise Equeue.Reject
+
+  method handle_timeout op =
+    self#log "Unhandled timeout";
+    raise Equeue.Reject
+
+  method handle_signal () =
+    self#log "Unhandled signal";
+    raise Equeue.Reject
+
+  method handle_extra exn =
+    self#log "Unhandled extra";
+    raise Equeue.Reject
+
+  method handle_close () =
+    self#log "Closed";
+    ()
+
+end
+
+
+(** Establish a server on the given address.
+
+    [connection_handler] will be called with the file descriptor of
+    any new connections.
+*)
+let establish_server ues connection_handler addr =
+  let g = ues#new_group () in
+  let handle_event ues esys e =
+    match e with
+      | Input_arrived (g, fd) ->
+	  let cli_fd, cli_addr = Unix.accept fd in
+	    connection_handler cli_fd
+      | _ ->
+	  raise Equeue.Reject
+  in
+  let srv = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+    Unix.bind srv addr;
+    Unix.listen srv 50;
+    Unix.setsockopt srv Unix.SO_REUSEADDR true;
+    ues#add_handler g handle_event;
+    ues#add_resource g (Wait_in srv, -.1.0)
+
+
diff --git a/irc.ml b/irc.ml
new file mode 100644
index 0000000..040797b
--- /dev/null
+++ b/irc.ml
@@ -0,0 +1,284 @@
+open Uq_engines
+open Unixqueue
+
+let newline_re = Pcre.regexp "\n\r?"
+let argsep_re = Pcre.regexp " :"
+let space_re = Pcre.regexp " "
+
+let string_map f s =
+  let l = String.length s in
+  if l = 0 then
+    s
+  else
+    let r = String.create l in
+      for i = 0 to l - 1 do
+	String.unsafe_set r i (f (String.unsafe_get s i))
+      done;
+      r
+
+let lowercase_char c =
+  if (c >= 'A' && c <= '^') then
+    Char.unsafe_chr(Char.code c + 32)
+  else
+    c
+
+let uppercase_char c =
+  if (c >= 'a' && c <= '~') then
+    Char.unsafe_chr(Char.code c - 32)
+  else
+    c
+
+let uppercase s = string_map uppercase_char s
+let lowercase s = string_map lowercase_char s
+
+    
+class irc (ues : unix_event_system) =
+object (self)
+
+  val mutable debug = false
+  val throttle_interval = 1.0
+
+  (** Group for this bot's events *)
+  val g = ues#new_group ()
+
+  val out_wait_id = ues#new_wait_id ()
+  val mutable check_output = None
+  val mutable output_pending = ""
+  val mutable input_pending = ""
+  val outq_immediate = Queue.create ()
+  val outq_throttled = Queue.create ()
+  val outq_last_sent = Unix.time ()
+
+  initializer
+    ues#add_handler g self#handle_event
+
+  method debug v =
+    debug <- v
+
+  method log msg =
+    if debug then
+      prerr_endline msg
+
+  method handle_event ues' esys e =
+    assert (ues' = ues);
+    match e with
+      | Input_arrived (g, fd) ->
+	  self#handle_input fd
+      | Output_readiness (g, fd) ->
+	  self#handle_output fd
+      | Out_of_band (g, fd) ->
+	  self#handle_oob fd
+      | Timeout (g, op) ->
+	  self#handle_timeout op
+      | Signal ->
+	  self#handle_signal ()
+      | Extra exn ->
+	  self#handle_extra exn
+
+  method handle_input fd =
+    let s = 4096 in
+    let buf = String.create s in
+    let len = Unix.read fd buf 0 s in
+    let input = input_pending ^ (String.sub buf 0 len) in
+      if (input <> "") then
+	let lines = Pcre.split ~rex:newline_re input in
+	let rec handle_lines lines =
+	  match lines with
+	    | [] 
+	    | [""] ->
+		input_pending <- "";
+	    | line :: tl ->
+		self#handle_line line;
+		handle_lines tl
+	in
+	  handle_lines lines
+      else
+	begin
+	  Unix.close fd;
+	  ues#clear g;
+	end
+      
+
+  method handle_output fd =
+    let data = (
+      if (output_pending <> "") then 
+	output_pending
+      else if not (Queue.is_empty outq_immediate) then
+	Queue.pop outq_immediate
+      else if not (Queue.is_empty outq_throttled) then
+	begin
+	  (* Stop listening for output events; add a timeout to
+	     start listening again *)
+	  (match check_output with
+	     | None -> ()
+	     | Some co -> 
+		 let pay_attention () =
+		   ues#add_resource g (co, -.1.0)
+		 in
+		 ues#remove_resource g co;
+		 ues#once g throttle_interval pay_attention
+	  );
+	  Queue.pop outq_throttled
+	end
+      else
+	match check_output with
+	  | None -> ""
+	  | Some co ->
+	      ues#remove_resource g co;
+	      ""
+    ) in
+    let data_len = String.length data in
+    let n = Unix.single_write fd data 0 data_len in
+      output_pending <- String.sub data n (data_len - n);
+      if (data <> "") then
+	self#log ("--> " ^ (String.escaped data))
+
+  method handle_oob fd =
+    self#log "OOB ready!";
+    raise Equeue.Reject
+
+  method handle_timeout op =
+    self#log "Timeout!";
+    raise Equeue.Reject
+
+  method handle_signal () =
+    self#log "Signal!";
+    raise Equeue.Reject
+
+  method handle_extra exn =
+    self#log "Extra!";
+    raise Equeue.Reject
+
+  method handle_line line =
+    let argstr, txt =
+      match Pcre.split ~max:2 ~rex:argsep_re line with
+	| [] -> ("", "")
+	| [a] -> (a, "")
+	| [a; b] -> (a, b)
+	| _ -> ("", "")
+    in
+    let sender, args =
+      let args' = Pcre.split ~rex:space_re argstr in
+	if (debug) then
+	  print_endline ("<-- [" ^
+			   (String.concat "; " args') ^
+			   "] " ^
+			   txt);
+	if (List.hd args').[0] = ':' then
+	  (List.hd args', List.tl args')
+	else
+	  ("", args')
+    in
+      match args with
+	| [] ->
+	    ()
+	| "NOTICE" :: args ->
+	    let tlen = String.length txt in
+	      if ((txt.[0] = '\001') &&
+		    (txt.[tlen - 1] = '\001')) then
+		self#handle_ctcp_reply sender args (String.sub txt 1 (tlen - 2))
+	      else
+		self#handle_notice sender args txt
+	| "PRIVMSG" :: args ->
+	    let tlen = String.length txt in
+	      if ((txt.[0] = '\001') &&
+		    (txt.[tlen - 1] = '\001')) then
+		self#handle_ctcp_request sender args (String.sub txt 1 (tlen - 2))
+	      else
+		self#handle_privmsg args sender txt
+	| ["PING"] ->
+	    self#handle_ping txt
+	| str :: args ->
+	    let numeric =
+	      try
+		Some (int_of_string str)
+	      with Failure _ ->
+		None
+	    in
+	      match numeric with
+		| Some n ->
+		    self#handle_numeric n sender args txt
+		| None ->
+		    self#handle_unknown sender args txt
+	
+
+  method handle_privmsg sender args txt =
+    ()
+
+  method handle_notice sender args txt =
+    ()
+
+  method handle_ctcp_request sender args txt =
+    ()
+
+  method handle_ctcp_reply sender args txt =
+    ()
+
+  method handle_numeric n sender args txt =
+    ()
+
+  method handle_unknown sender args txt =
+    self#log ("Got unknown server message")
+
+  method handle_ping txt =
+    self#send ["PONG"] txt
+
+  (** Public methods *)
+
+  method set_fd fd nick gecos =
+    (* XXX: Clear old junk *)
+    check_output <- Some (Wait_out fd);
+    ues#add_resource g (Wait_in fd, -.1.0);
+    self#send ~now:true ["USER"; nick; "+iw"; nick] gecos;
+    self#send ~now:true ["NICK"; nick] ""
+
+  (** Send a command to the IRC server *)
+  method send ?(now=false) args txt =
+    match check_output with
+      | None -> ()
+      | Some co ->
+	  let q = (if now then outq_immediate else outq_throttled) in
+	  let cmdstr =
+	    (String.concat " " args) ^
+	      (if txt = "" then "" else " :") ^
+	      txt ^
+	      "\n"
+	  in
+	    Queue.push cmdstr q;
+	    ues#add_resource g (co, -.1.0)
+
+  (** Send a private message *)
+  method privmsg ?(now=false) recipient txt =
+    self#send ~now ["PRIVMSG"; recipient] txt
+
+  (** Send a notice *)
+  method notice ?(now=false) recipient txt =
+    self#send ~now ["NOTICE"; recipient] txt
+
+  (** Send a CTCP request *)
+  method ctcp_request ?(now=false) recipient command txt =
+    self#privmsg ~now recipient ("\001" ^ command ^ " " ^ txt ^ "\001")
+
+  (** Send a CTCP reply *)
+  method ctcp_reply ?(now=false) recipient command txt =
+    self#notice ~now recipient ("\001" ^ command ^ " " ^ txt ^ "\001")
+
+end
+
+
+let main() =
+  let ues = new unix_event_system () in
+  let c = connector (`Socket(`Sock_inet_byname(Unix.SOCK_STREAM,
+                                               "woozle.org", 6667),
+                             default_connect_options
+                            )) ues in
+    when_state
+      ~is_done:(fun connstat ->
+		  match connstat with
+		    | `Socket(fd, _) ->
+			let b = new irc ues in
+			  b#set_fd fd "plasma" "Plasma Bot"
+		    | _ -> assert false
+	       )
+      c;
+    Unixqueue.run ues
diff --git a/ircd.ml b/ircd.ml
new file mode 100644
index 0000000..44973cc
--- /dev/null
+++ b/ircd.ml
@@ -0,0 +1,24 @@
+open Unixqueue
+
+class ircd_connection (ues : unix_event_system) fd =
+object (self)
+  inherit Connection.connection ues fd
+end
+
+
+let main () =
+  let ues = new unix_event_system () in
+  let handle_connection fd =
+    prerr_endline "hi!";
+    let c = new ircd_connection ues fd in
+      c#debug true
+  in
+    Connection.establish_server
+       ues
+      handle_connection
+      (Unix.ADDR_INET (Unix.inet_addr_any, 7777));
+    ues#run ()
+
+let _ =
+  main ()
+
diff --git a/tests.ml b/tests.ml
new file mode 100644
index 0000000..3b333e5
--- /dev/null
+++ b/tests.ml
@@ -0,0 +1,57 @@
+open Unixqueue
+open OUnit
+open Chat
+
+let do_chat script () =
+  let irc_instance ues fd =
+    let irc = new Irc.irc ues in
+      irc#set_fd fd "nick" "gecos";
+      irc#debug true
+  in
+    chat script irc_instance
+
+let normal_tests =
+  let login_script =
+    [
+      Recv "USER nick +iw nick :gecos\n";
+      Recv "NICK nick\n";
+      Send ":testserver.test NOTICE nick :*** Hi there.\n";
+      Send "PING :12345\n";
+      Recv "PONG :12345\n";
+    ]
+  in
+    "Normal tests" >:::
+      [
+	"Simple connection" >::
+	  (do_chat
+	     login_script);
+
+	"Full connection" >::
+	  (do_chat
+	     ([Send ":testserver.test NOTICE AUTH :*** Doing some pointless ident junk...\n"] @
+		login_script @
+		[
+		  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 003 nick :This server is timeless\n";
+		  Send ":testserver.test 004 nick testserver.test testscript DGabcdfg bilmnopst bkloveI\n";
+		  Send ":testserver.test 005 nick CALLERID CASEMAPPING=rfc1459 KICKLEN=160 MODES=4 WHATEVER=4 WHO=1 CARES=3 :are supported by this server\n";
+		  Send ":testserver.test 043 00XAAAAL6 :your unique ID\n";
+		  Send ":testserver.test 251 nick :There are 14 users and 4 invisible on 1 servers\n";
+		  Send ":testserver.test 252 nick 1 :IRC Operators online\n";
+		  Send ":testserver.test 254 4 :channels formed\n";
+		  Send ":testserver.test 255 nick :I have 17 clients and 0 servers\n";
+		  Send ":testserver.test 265 nick :Current local users: 17  Max: 25\n";
+		  Send ":testserver.test 266 nick :Current global users: 17  Max: 25\n";
+		  Send ":testserver.test 250 nick :Highest connection count: 25 (25 clients) (430 connections received)\n";
+		  Send ":testserver.test 375 nick :- xirc.lanl.gov Message of the Day -\n";
+		  Send ":testserver.test 372 nick :- This is ircd-hybrid MOTD replace it with something better\n";
+		  Send ":testserver.test 376 nick :End of /MOTD command.\n";
+		]
+	     ));
+      ]
+
+let _ =
+  run_test_tt_main (TestList [normal_tests])
+	
+