From eccaa1b4ffa52a6477ea1dd55e43798236e58da6 Mon Sep 17 00:00:00 2001 From: Neale Pickett Date: Fri, 8 Feb 2008 15:38:31 -0700 Subject: [PATCH] Accepting connections and line-buffering input --- Makefile | 34 ++++++ README | 17 +++ chat.ml | 141 +++++++++++++++++++++++++ connection.ml | 168 +++++++++++++++++++++++++++++ irc.ml | 284 ++++++++++++++++++++++++++++++++++++++++++++++++++ ircd.ml | 24 +++++ tests.ml | 57 ++++++++++ 7 files changed, 725 insertions(+) create mode 100644 Makefile create mode 100644 README create mode 100644 chat.ml create mode 100644 connection.ml create mode 100644 irc.ml create mode 100644 ircd.ml create mode 100644 tests.ml 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]) + +