neale
/
irc-bot
mirror of https://github.com/nealey/irc-bot
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Accepting connections and line-buffering input

This commit is contained in:
Neale Pickett 2008-02-08 15:38:31 -07:00
commit eccaa1b4ff
7 changed files with 725 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
Makefile Normal file
View File

@ -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

17
README Normal file
View File

@ -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.

141
chat.ml Normal file
View File

@ -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)))

168
connection.ml Normal file
View File

@ -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)

284
irc.ml Normal file
View File

@ -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

24
ircd.ml Normal file
View File

@ -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 ()

57
tests.ml Normal file
View File

@ -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])