commit - 7317d784aaa81fab85efb43c0ce240c22bb063bb
commit + 333e51c3107833915c41cfcd0939b6ae6faffe2d
blob - 471f8e0dbf91ea52a60c8cb78ed77f6c7660a78f
blob + 2809d81a4a80f7a0d805fb323e972d3f1680b4da
--- mata_bot.pl
+++ mata_bot.pl
#!/usr/bin/perl
use v5.40;
-use Getopt::Std;
use HTTP::Tiny;
use IO::Select;
use IO::Socket qw(AF_INET SOCK_STREAM);
use IO::Socket::SSL;
-use POSIX qw(strftime);
-my $NVERSES_BIBLE = 31102;
-my $NVERSES_QURAN = 6348;
-my $CHUNK_LENGTH = 512;
+use constant {
+ LOG_ERROR => 0,
+ LOG_WARN => 1,
+ LOG_DEBUG => 2,
+};
+
my $CONNECT_TIMEOUT = 60;
-my $RECONNECT_TIME = 60;
-my $SOCK_TIMEOUT = 10;
-my $PING_TIMEOUT = 120;
-my $PONG_TIMEOUT = 300;
my $DEFAULT_CHAN = '#testmatabot';
my $DEFAULT_HOST = 'localhost';
-my $DEFAULT_LOGGING = 0;
-my $DEFAULT_LOGLEVEL = 'none';
my $DEFAULT_PATH_BALL = '/usr/local/share/matabot/ball';
-my $DEFAULT_PATH_HELLOS = '/usr/local/share/matabot/hellos';
-my $DEFAULT_PATH_QUOTES = '/usr/local/share/matabot/quotes';
+my $DEFAULT_PATH_HELO = '/usr/local/share/matabot/hellos';
+my $DEFAULT_PATH_QUOT = '/usr/local/share/matabot/quotes';
my $DEFAULT_PORT = 6667;
my $DEFAULT_TLS = 0;
-my $MATA_CUTE = '[>.<]';
-my $MATA_DEAD = '[x~x]';
-my $MATA_FLIPOFF = 't[-_-t]';
-my $MATA_HAPPY = '[^_^]';
-my $MATA_NORM = '[._.]';
-my $MATA_SING = '[^=^]';
-my $MOTHER = 'noodle';
-my $NICK = 'mata_bot';
-my $NICK_RE = qr/mata_?bo[ity]+/i;
-my $REAL = 'death to technomage!!';
-my $USER = 'mata_bot_beta4';
+my $FCUTE = '[>.<]';
+my $FDEAD = '[x~x]';
+my $FFLIP = 't[-_-t]';
+my $FGLAD = '[^_^]';
+my $FNORM = '[._.]';
+my $FSING = '[^=^]';
+my $IRCMAX = 512;
+my $LAG_CHECK_TIME = 120;
+my $MAX_LAG = 300;
+my $MOM = 'noodle';
+my $MYNICK = 'mata_bot';
+my $MYREAL = 'death to technomage!!';
+my $MYUSER = 'mata_bot_beta4';
+my $NICKRE = qr/mata_?bo[ity]+/i;
+my $RECONN_SLEEP = 60;
+my $SOCK_TIMEOUT = 10;
+my %NVERSE = (
+ 'bible' => 31102,
+ 'quran' => 6348,
+);
sub randint {
my($min, $max) = @_;
+
return $min if $min == $max;
- ($min, $max) = ($max, $min) if $min > $max;
+ ($min, $max) = ($max, $min) if $min > $max;
return $min + int rand(1 + $max - $min);
}
-sub respond_command {
- my ($ball, $hellos, $sender_nick, $content) = @_;
- my $reply = '';
- if ($content =~ /\b{wb}([1-9]\d*)?d([1-9]\d*)\b{wb}/) {
- # we got dice
- my $ndice = $1 // 1;
- my $nface = $2;
- my $min = $ndice;
- my $max = $ndice * $nface;
- my $result = randint($min, $max);
- my $roll = 'd' . $nface;
- $roll = $ndice . $roll if $ndice > 1;
- $reply = "${sender_nick} rolled a ${roll} and got ${result}! ${MATA_HAPPY}";
- } elsif ($content =~ /\b{wb}pray+\b{wb}/) {
- $reply = "Stay prayed up!! ${MATA_CUTE}";
- } elsif ($content =~ /\b{wb}bru[hv]+\b{wb}/i) {
- $reply = "Did i stutter? ${MATA_NORM}";
- } elsif ($content =~ /\b{wb}f+(u?ck+)? *(yo)?u+\b{wb}/i) {
- $reply = $MATA_FLIPOFF
- } elsif ($content =~ /\b{wb}i+ *l+(ove+)? *(you+|y+|u+)\b{wb}/i) {
- $reply = "<3 ${MATA_HAPPY}"
- } elsif ($content =~ /(thanks+|thx+|thank +(yo)?u+)( *a+ *lot+)?/i) {
- $reply = "You're welcome, ${sender_nick}! ${MATA_HAPPY}"
- } elsif ($content =~ /who('| +i|)s+ +(a|the)+ +goo+d+ +(bo+[ity]+o*|gir(l+|lie+))/i) {
- $reply = "Me! ${MATA_CUTE}"
- } elsif ($content =~ /
- h(ow+)?\s*(are+|r+)\s*(you+|yo+|u+)(\s+doing+)?(\s+today+)?|
- how('|\si|)s+\s+(it+\s+going+|life+|everything+)
- /ix) {
- $reply = "I feel fantaaaastic... hey, hey, hey! ${MATA_SING}"
- } elsif ($content =~ /\b{wb}(
- what('|\si|)s+\s*(up+|happening+|cracking+)|
- (was)?sup+
- )\b{wb}/ix) {
- $reply = "Looking for technomage, and you? ${MATA_NORM}"
- } elsif ($content =~ /\?$/) {
- # we got a question
- $reply = "$ball->[rand @$ball] ${MATA_CUTE}"
- } elsif ($content =~ /\b{wb}(
- goo+d+\s*(bo+[ity]+o*|gir(l+|lie+))|
- w(elcome+)?\s*(b+|back+)
- )\b{wb}/ix) {
- if ($sender_nick eq $MOTHER) {
- $reply = "Thank you, mother! ${MATA_HAPPY}"
+sub strip {
+ my $s = shift;
+ return trim($s =~ tr/\0\r\n//dr);
+}
+
+sub replycmd {
+ my ($ball, $helo, $nick, $content) = @_;
+ my ($ismom, $reply);
+
+ $nick = 'mother' if $ismom = $nick eq $MOM;
+ $_ = $content;
+ if (/\b{wb}([1-9][0-9]*)?d([1-9][0-9]*)\b{wb}/) {
+ my ($ndice, $nface, $n, $roll);
+
+ ($ndice, $nface) = ($1 // 1, $2);
+ $n = randint($ndice, $ndice*$nface);
+ $roll = ($ndice > 1 ? $ndice : '') . 'd' . $nface;
+ $reply = "${nick} rolled a ${roll} and got ${n}! ${FGLAD}";
+ } elsif (/pray/i) {
+ $reply = "Stay prayed up!! ${FCUTE}";
+ } elsif (not $ismom and /\b{wb}bru[hv]+\b{wb}/i) {
+ $reply = "Did i stutter? ${FNORM}";
+ } elsif (not $ismom and /\b{wb}f+(u?ck+)? *(yo)?u+\b{wb}/in) {
+ $reply = $FFLIP;
+ } elsif (/\b{wb}i+ *l+(ove+)? *(you+|y+|u+)\b{wb}|<3/in) {
+ $reply = "<3 ${FGLAD}";
+ } elsif (/(thanks+|thx+|thank +(yo)?u+)( *a+ *lot+)?/in) {
+ $reply = "You're welcome, ${nick}! ${FGLAD}";
+ } elsif (/
+ who(('|\s+i)?s+)?\s+(a|the)+\s+goo+d+\s+(bo+[ity]+o*|gi+r+l+(i+e+)?)
+ /inx) {
+ $reply = "Me! ${FCUTE}";
+ } elsif (/
+ h(ow+)?\s*(are+|r+)\s*(you+|yo+|u+)(\s+doing+)?(\s+today+)?|
+ how('|\si|)s+\s+(it+\s+going+|life+|everything+)
+ /inx) {
+ $reply = "I feel fantaaaastic... hey, hey, hey! ${FSING}";
+ } elsif (/
+ \b{wb}(
+ what('|\si|)s+\s*(up+|happening+|cracking+)|
+ (was)?sup+
+ )\b{wb}
+ /inx) {
+ $reply = "Looking for technomage, and you? ${FNORM}";
+ } elsif (/\?$/) {
+ $reply = "$ball->[rand @$ball] ${FCUTE}";
+ } elsif (/
+ \b{wb}(
+ goo+d+\s*(bo+[ity]+o*|gir(l+|lie+))|
+ w(elcome+)?\s*(b+|back+)
+ )\b{wb}
+ /inx) {
+ $reply = "Thank you, ${nick}! ${FGLAD}";
+ } elsif (/
+ \b{wb}(
+ (a[ls]+-?)?sala+m+u*\s*['3a]lai+kum+u*|
+ ay+|
+ g('day+|oo+d\s+(day+|morning+|afternoo+n+|evening+))|
+ greetings+|
+ h(([aeo](i+|llo+)|ey+|i+(ya+)?)(\s+there+)?|owdy+)|
+ hail+|
+ (morn|even)ings+|
+ noo+nafters+|
+ oi+|
+ salutations+|
+ well+\s+met+|
+ yo+
+ )\b{wb}
+ /inx) {
+ $reply = "$helo->[rand @$helo], ${nick}! ${FGLAD}";
+ } elsif (/a+l{2,}a+h|g[o-]d/i) {
+ my ($book, $n, $r);
+
+ $book = $& =~ /^a/ ? 'quran' : 'bible';
+ $n = randint(1, $NVERSE{$book});
+ $r = HTTP::Tiny->new->get("https://triapul.cz/files/${book}/${n}");
+ if ($r->{success}) {
+ $reply = strip($r->{content});
+ } elsif ($book eq 'quran') {
+ $reply = "Allah will not any answer prayers until the server fixes it's polytheist ways!! ${FCUTE}";
} else {
- $reply = "Thanks, ${sender_nick}! ${MATA_HAPPY}"
+ $reply = "God is Dead!! ${FCUTE}";
}
- } elsif ($content =~ /\b{wb}(
- (al+-?)?sala+m+u*\s+alaikum+u*|
- (morn|even)ings+|
- g('day+|oo+d\s+(day+|morning+|afternoo+n+|evening+))|
- greetings+|
- h(([aeo](i+|llo+)|ey+|i+(ya+)?)(\s+there+)?|owdy+)|
- hail+|
- noo+nafters+|
- oi+|
- salutations+|
- well+\s+met+|
- yo+
- )\b{wb}/ix) {
- $reply = "$hellos->[rand @$hellos], ${sender_nick}! ${MATA_HAPPY}"
- } elsif ($content =~ /(a+l{2,}a+h|g[o-]d)/i) {
- my $response;
- if ($1 =~ /^a/) {
- $response = HTTP::Tiny->new->get("http://triapul.cz/files/quran/@{[randint(1, $NVERSES_QURAN)]}");
- $reply = "Allah will not answer prayers until server fixes it's polytheist ways!! ${MATA_CUTE}";
- } else {
- $response = HTTP::Tiny->new->get("http://triapul.cz/files/bible/@{[randint(1, $NVERSES_BIBLE)]}");
- $reply = "God is Dead!! ${MATA_CUTE}";
- }
- if ($response->{success}) {
- my $body = $response->{content};
- $body =~ tr/\000\r\n//d;
- $body = trim($body);
- $reply = $body if $body;
- }
- } elsif ($sender_nick eq $MOTHER) {
- $reply = "Done, mother! ${MATA_HAPPY}"
+ } elsif ($ismom) {
+ $reply = "Done, mother! ${FGLAD}";
} else {
- $reply = "\1ACTION leans over and places it's hand near it's antenna. \"HUUH?\" ${MATA_NORM}\1";
+ $reply = "\1ACTION leans over and places its hand near its antenna. \"HUUH?\" ${FNORM}\1";
}
return $reply;
}
-sub respond_mention {
- my ($quotes, $sender_nick, $message) = @_;
- my $reply = '';
- if ($sender_nick eq $MOTHER) {
- $reply = "Yes, mother? ${MATA_HAPPY}";
- } elsif ($message =~ /^\b${NICK_RE}\b$/) {
- $reply = "${MATA_NORM} ?";
+sub replyhil {
+ my ($quotes, $nick, $msg) = @_;
+
+ if ($nick eq $MOM) {
+ return "Yes, mother? ${FGLAD}";
+ } elsif ($msg =~ /^${NICKRE}\W*$/) {
+ return "${FNORM} ?";
} else {
- $reply = "$quotes->[rand @$quotes] ${MATA_NORM}";
+ return "$quotes->[rand @$quotes] ${FNORM}";
}
- return $reply;
}
-# respond to channel
sub respond {
- my ($lists, $subbuffer, $sender_nick, $message) = @_;
- my $reply = '';
- if ($subbuffer->{$sender_nick} && $message =~ m,\b{wb}s/([^/]+)/([^/]*)(?:/([gi]*))?,) {
+ state %lastmsg;
+ my ($nick, $msg, ($ball, $helo, $quot)) = @_;
+ my $reply;
+
+ $reply = '';
+ $_ = $msg;
+ if (m,\b{wb}s/([^/]+)/([^/]*)(?:/([gi]*))?,) {
# chat s///
- my $prev_message = $subbuffer->{$sender_nick};
- my $retext = $1;
- my $repl = $2;
- my $mods = $3 // '';
- my $regex;
- my $imod = $mods =~ /i/ ? 'i' : '';
- eval {
- $regex = qr/(?$imod:$retext)/
- };
- return $prev_message, '' if $@;
- my $ismatch;
+ my ($didsub, $imod, $mods, $regex, $retext, $repl);
+
+ $lastmsg{$nick} or return '';
+ ($retext, $repl, $mods) = ($1, $2, $3 // '');
+ $imod = $mods =~ /i/ ? 'i' : '';
+ eval { $regex = qr/(?$imod:$retext)/ } or return '';
if ($mods =~ /g/) {
- $ismatch = $prev_message =~ s/$regex/$repl/g;
+ $didsub = $lastmsg{$nick} =~ s/$regex/$repl/g;
} else {
- $ismatch = $prev_message =~ s/$regex/$repl/;
+ $didsub = $lastmsg{$nick} =~ s/$regex/$repl/;
}
- if ($ismatch) {
- $reply = "${sender_nick} meant to say: ${prev_message}"
+ $reply = "${nick} meant to say: $lastmsg{$nick}" if $didsub;
+ return $reply;
+ }
+ $lastmsg{$nick} = $msg;
+ if (m,watch\?v=([a-zA-Z0-9_-]+),) {
+ # post youtube video title from ID
+ my ($id, $q, $r);
+
+ $id = $1;
+ $q = "?s=https%3A//youtube.com/watch%3Fv%3D${1}&o=relevance";
+ $r = HTTP::Tiny->new->get("https://fuyt.lab8.cz/${q}");
+ unless ($r->{success}) {
+ return "${1}: $r->{status} $r->{reason}! ${FDEAD}";
}
- return $prev_message, $reply;
- } elsif ($message =~ m,watch\?v=([a-zA-Z0-9_-]+),) {
- # post youtube video titles from video ID
- my $video_id = $1;
- my $response = HTTP::Tiny->new->get("https://fuyt.lab8.cz/?s=https%3A//www.youtube.com/watch%3Fv%3D${video_id}&o=relevance");
- unless ($response->{success}) {
- $reply = "failed to get title of youtube video ${video_id} ${MATA_DEAD} ($response->{status} $response->{reason}!)";
- return $message, $reply;
+ unless (length $r->{content}) {
+ return "${1}: empty HTTP response! ${FDEAD}";
}
- unless (length $response->{content}) {
- $reply = "failed to get title of youtube video ${video_id} ${MATA_DEAD} (HTTP response empty!)";
- return $message, $reply;
+ unless ($r->{content} =~ m,
+ <span\sclass="title">
+ <a\shref="https://www\.youtube\.com/watch\?v=${id}"
+ \saccesskey="0">([^<]+)</a>
+ ,ix) {
+ return "${1}: no video matching ID found! ${FDEAD}";
}
- my $body = $response->{content};
- if ($body =~ m,<span class="title"><a href="https://www\.youtube\.com/watch\?v=${video_id}" accesskey="0">([^<]+)</a>,i) {
- my $title = $1;
- $title =~ tr/\000\r\n//d;
- $title = trim($title);
- $reply = "YouTube: ${title}";
- } else {
- $reply = "failed to get title of video ${video_id} ${MATA_DEAD} (no videos matching ID ${video_id}!)";
+ $reply = 'YouTube: ' . strip($1);
+ } elsif (
+ m,https?://([^ /]*[^ ./0-9][^ /]*\.)+[^ /]*[^ ./0-9][^ /]*(/[^ ]*)?,n
+ ) {
+ # post website title for text/html or mimetype otherwise
+ my ($r, $url);
+
+ $url = $&;
+ $r = HTTP::Tiny->new->head($url);
+ unless ($r->{success}) {
+ return "HEAD ${url}: $r->{status} $r->{reason}! ${FDEAD}";
}
- } elsif ($message =~ m,https?://[^ ]+,) {
- my $url = $&;
- # get in it's HEAD to check if it's text/html
- my $response = HTTP::Tiny->new->head($url);
- unless ($response->{success}) {
- $reply = "$response->{status} $response->{reason} (HEAD ${url}) ${MATA_DEAD}";
- return $message, $reply;
+ unless ($r->{headers}->{'content-type'}) {
+ return "HEAD ${url}: empty MIME type! ${FDEAD}";
}
- unless ($response->{headers}->{'content-type'}) {
- $reply = "no content-type header in HTTP response (HEAD ${url}) ${MATA_DEAD}";
- return $message, $reply;
+ unless ($r->{headers}->{'content-type'} =~ m,text/html,) {
+ return "File: $r->{headers}->{'content-type'}";
}
- unless ($response->{headers}->{'content-type'} =~ m,text/html,) {
- # we got a non text/html content type
- $reply = "File: $response->{headers}->{'content-type'}";
- return $message, $reply;
+ $r = HTTP::Tiny->new->get($url);
+ unless ($r->{success}) {
+ return "GET ${url}: $r->{status} $r->{reason}! ${FDEAD}";
}
-
- # if it's text/html, GET it's title
- $response = HTTP::Tiny->new->get($url);
- unless ($response->{success}) {
- $reply = "$response->{status} $response->{reason} (GET ${url}) ${MATA_DEAD}";
- return $message, $reply;
+ unless ($r->{content}) {
+ return "GET ${url}: empty HTTP response! ${FDEAD}";
}
- unless (length $response->{content}) {
- $reply = "Empty HTTP response (GET ${url}) ${MATA_DEAD}";
- return $message, $reply;
+ unless ($r->{content} =~ m,<title[^>]*>([^<]+)</title[^>]*>,i) {
+ return "GET ${url}: no title found! ${FDEAD}";
}
- my $body = $response->{content};
- if ($body =~ m,<title[^>]*>([^<]+)</title[^>]*>,i) {
- my $title = $1;
- $title =~ tr/\000\r\n//d;
- $title = trim($title);
- $reply = "Title: ${title}";
- } else {
- $reply = "No title found (GET ${url} ${MATA_DEAD}";
- }
- # TODO: this part should use [^ ] and .* instead but i'm scared of .*
- } elsif ($message =~ /^ *${NICK_RE}[:, ] *([^\000\r\n ][^\000\r\n]*)$/
- or $message =~ /^ *([^\000\r\n ][^\000\r\n]*)[, ] *${NICK_RE}[\W\d]*$/) {
- $reply = respond_command($lists->{'ball'}, $lists->{'hellos'}, $sender_nick, $1);
- } elsif ($message =~ /\b${NICK_RE}\b/) {
- $reply = respond_mention($lists->{'quotes'}, $sender_nick, $message);
+ $reply = 'Title: ' . strip($1);
+ } elsif (/^ *${NICKRE}[:, ] *(\W?[^ \W].*)$/
+ or /^ *([^ ].*)[, ] *${NICKRE}([\W\d]*)$/) {
+ $reply = replycmd($ball, $helo, $nick, $1 . ($2//''));
+ } elsif (/\b${NICKRE}\b/) {
+ $reply = replyhil($quot, $nick, $msg);
}
- return $message, $reply;
+ return $reply;
}
sub logger {
- my ($opts, $level, $message) = @_;
- return if not $opts->{'logging'};
- if ($level eq 'error') {
- return if not $opts->{'loglevel'} =~ /^(?:error|info)$/;
- $message = '!! ' . $message;
- } elsif ($level eq 'info') {
- return if $opts->{'loglevel'} ne 'info';
+ state $loglevel = LOG_ERROR;
+ my ($level, $msg) = @_;
+
+ if ($msg) {
+ syswrite(STDERR, $msg . "\n") if $loglevel >= $level
} else {
- die "logger: invalid logging level '${level}'!";
+ $loglevel = $level;
}
- $message = strftime('%Y-%m-%dT%H:%M:%SZ ', gmtime()) . $message . "\n";
- print STDERR $message;
}
-sub out {
- my ($sock, $opts, $message) = @_;
- my $s = IO::Select->new($sock);
+sub sendmsg {
+ my ($s, $msg) = @_;
+ my $sock;
+
$! = 0;
- if ($s->can_write($SOCK_TIMEOUT)) {
- print $sock $message . "\r\n";
- logger($opts, 'info', '<- ' . $message);
- return 1;
- } else {
- if ($!) { logger($opts, 'error', $!); return; }
+ unless (($sock) = $s->can_write($SOCK_TIMEOUT)) {
+ if ($!) { logger(LOG_ERROR, $!) }
+ else { logger(LOG_WARN, "sock not ready to write") }
return 0;
}
+ syswrite($sock, $msg . "\r\n");
+ logger(LOG_DEBUG, "<- " . $msg);
+ return 1;
}
+sub recvmsg {
+ state $buf = '';
+ my $s = shift;
+
+ while(1) {
+ my ($chunk, $sock);
+
+ $_ = $buf;
+ if (not length) {
+ } elsif (/\A([^\0\n\r]+)\r\n(.+)?\z/s) {
+ logger(LOG_DEBUG, "-> " . $1);
+ $buf = $2 // '';
+ return $1;
+ } elsif (/\n\n|\n\r|\r\r|\r[^\n\r]|[^\n\r]\n/) {
+ logger(LOG_ERROR, 'recieved a malformed message');
+ return undef;
+ }
+ # read a chunk
+ $! = 0;
+ unless (($sock) = $s->can_read($SOCK_TIMEOUT)) {
+ if ($!) {
+ logger(LOG_ERROR, $!);
+ return undef;
+ }
+ return '';
+ }
+ unless (sysread($sock, $chunk, 1)) {
+ if ($!) { logger(LOG_ERROR, $!) }
+ else { logger(LOG_WARN, 'recieved an empty message') }
+ return undef;
+ }
+ $buf .= $chunk;
+ }
+}
+
sub evasdrop {
- my ($sock, $opts, $lists, $subbuffer) = @_;
- my $buffer = '';
- my $checkping = 1;
- my $chunk = '';
- my $message = '';
- my $pingtime = time;
- my $pongtime = time;
- my $s = IO::Select->new($sock);
- my %subbuffer;
+ my ($s, $host, $chan, $lists) = @_;
+ my ($checkping, $msgmax, $pingtime, $pongtime, $prefixlen, $priv);
+ $checkping = 1;
+ $priv = "PRIVMSG ${chan} :";
+ $pongtime = $pingtime = time;
while (1) {
- my $reply = '';
- $! = 0;
- if ($s->can_read($SOCK_TIMEOUT)) {
- # buffer up
- if ($opts->{'tls'}) {
- $chunk = <$sock>;
- } else {
- $sock->recv($chunk, $CHUNK_LENGTH);
- }
- if (not $chunk) {
- logger($opts, 'error', 'recv received an empty response');
+ defined($_ = recvmsg($s)) or return;
+ if(not length) {
+ } elsif (/^PING :([^ ]+)$/) {
+ sendmsg($s, 'PONG :' . $1);
+ } elsif (/^:[^ ]+ PONG/) {
+ $pongtime = $pingtime = time;
+ $checkping = 1;
+ } elsif (/^:[^ ]+ 352 [^ ]+ [^ ]+ [^ ]+ ([^ ]+)/) {
+ # the extra 2 bytes account for \r\n
+ $msgmax = $IRCMAX - length($1) - length($priv) - 2;
+ } elsif (/^:([^ !#&][^ !]*)![^ \@]+\@[^ ]+ ${priv}(.+)$/) {
+ # respond to chan message
+ my $r;
+
+ unless ($msgmax) {
+ logger(LOG_ERROR, 'could not calculate msgmax');
return;
}
- $chunk =~ /^([^\r\n]+)(\r\n)?([^\r\n]+)?$/;
- # keep reading if chunk is empty
- next if (not $1);
- # if chunks isn't empty, check for framing point
- if ($2) {
- # if we found a framing point, flush buffer and text till framing point
- $message = $buffer . $1;
- if ($3) {
- # if we have text after framing, make it the new content of buffer
- $buffer = $3;
- } else {
- # if we have no text after framing, clear buffer
- $buffer = '';
- }
- } else {
- # if there's no framing. append chunk to end of buffer and keep reading
- $buffer .= $chunk;
- next;
- }
- logger($opts, 'info', '-> ' . $message);
-
- # respond to message
- if ($message =~ /^PING :([^\000\r\n\ ]+)$/) {
- # if we got a ping, pong back
- $reply = "PONG :$1";
- } elsif ($message =~ /^:[^\000\r\n ]+ PONG/) {
- # if server ponged us back, reset ping-pong and allow pinging again
- $pingtime = time;
- $pongtime = time;
- $checkping = 1;
- } elsif ($message =~ /^:([^\000\r\n\#\&\ ][^\000\r\n\ ]*)![^\000\r\n\ ]+@[^\000\r\n\ ]+ PRIVMSG $opts->{'chan'} :([^\000\r\n]*)$/) {
- # if we got a message to our chan. read and act accordingly
- my $sender_nick = $1;
- my $sender_message = $2;
- ($subbuffer->{$sender_nick}, $reply) = respond($lists, $subbuffer, $sender_nick, $sender_message);
- # sanitize text and and form msg
- $reply =~ tr/\000\r\n//d;
- $reply = trim($reply);
- $reply = substr($reply, 0, $CHUNK_LENGTH-length("PRIVMSG #$opts->{'chan'} :"));
- $reply = "PRIVMSG $opts->{'chan'} :${reply}" if $reply;
- }
- out($sock, $opts, $reply) if $reply;
- } else {
- if ($!) { logger($opts, 'error', $!); return; }
+ $r = respond($1, $2, @$lists);
+ sendmsg($s, $priv . substr($r,0,$msgmax)) if length($r);
}
-
- # ping-pong
- if ($checkping and time-$pingtime >= $PING_TIMEOUT) {
+ if ($checkping and time-$pingtime > $LAG_CHECK_TIME) {
# ping server every once in a while and wait for pong
- out($sock, $opts, "PING $opts->{'host'}");
+ sendmsg($s, "PING :${host}");
$checkping = 0;
- } elsif (not $checkping and time-$pongtime >= $PONG_TIMEOUT) {
- # we leaving if we don't get ponged on time
- logger($opts, 'error', 'PONG response from server timed out');
- return
+ } elsif (not $checkping and time-$pongtime > $MAX_LAG) {
+ # we're leaving if we don't get ponged back on time
+ logger(LOG_WARN, 'server PONG response timed out');
+ return;
}
}
}
+sub usage {
+ syswrite(STDERR, "usage: ${0} [-d|-v] [-t] [-b path] [-e path] [-h host] [-j join] [-p port] [-q path]");
+ exit 1;
+}
+
sub init {
- my $ball_path = $DEFAULT_PATH_BALL;
- my $chan = $DEFAULT_CHAN;
- my $hellos_path = $DEFAULT_PATH_HELLOS;
- my $host = $DEFAULT_HOST;
- my $logging = $DEFAULT_LOGGING;
- my $loglevel = $DEFAULT_LOGLEVEL;
- my $port = $DEFAULT_PORT;
- my $quotes_path = $DEFAULT_PATH_QUOTES;
- my $tls = $DEFAULT_TLS;
+ my ($chan, $host, $path_ball, $path_helo, $path_quot, $port, $tls);
- getopts('tlvH:b:h:j:p:q:', \my %flags);
- $ball_path = $flags{'b'} if $flags{'b'};
- $chan = "#$flags{'j'}" if $flags{'j'};
- $hellos_path = $flags{'H'} if $flags{'H'};
- $host = $flags{'h'} if $flags{'h'};
- $port = $flags{'p'} if $flags{'p'};
- $quotes_path = $flags{'q'} if $flags{'q'};
- $tls = 1 if $flags{'t'};
- if ($flags{'l'}) {
- $logging = 1;
- $loglevel = 'error';
+ @_ = @ARGV;
+ while (@_) {
+ $_ = shift;
+ if (/^-d$/) { logger(LOG_DEBUG) }
+ elsif (/^-t$/) { $tls = 1 }
+ elsif (/^-v$/) { logger(LOG_WARN) }
+ elsif (@_ < 1) { usage() }
+ elsif (/^-b$/) { $path_ball = shift }
+ elsif (/^-e$/) { $path_helo = shift }
+ elsif (/^-h$/) { $host = shift }
+ elsif (/^-j$/) { $chan = '#' . shift }
+ elsif (/^-p$/) { $port = shift }
+ elsif (/^-q$/) { $path_quot = shift }
+ else { usage() }
}
- $loglevel = 'info' if $flags{'v'};
- open (my $ball_file, '<', $ball_path) or die "couldn't open ${ball_path}: $!";
+ open(my $ball_file, '<', $path_ball || $DEFAULT_PATH_BALL)
+ or die "couldn't open ${path_ball}: $!";
chomp(my @ball = <$ball_file>);
close $ball_file or die "${ball_file}: $!";
- open (my $hellos_file, '<', $hellos_path) or die "couldn't open ${hellos_path}: $!";
- chomp(my @hellos = <$hellos_file>);
- close $hellos_file or die "${hellos_file}: $!";
- open (my $quotes_file, '<', $quotes_path) or die "couldn't open ${quotes_path}: $!";
- chomp(my @quotes = <$quotes_file>);
- close $quotes_file or die "${quotes_file}: $!";
-
+ open(my $helo_file, '<', $path_helo || $DEFAULT_PATH_HELO)
+ or die "couldn't open ${path_helo}: $!";
+ chomp(my @helo = <$helo_file>);
+ close $helo_file or die "${helo_file}: $!";
+ open(my $quot_file, '<', $path_quot || $DEFAULT_PATH_QUOT)
+ or die "couldn't open ${path_quot}: $!";
+ chomp(my @quot = <$quot_file>);
+ close $quot_file or die "${quot_file}: $!";
return {
- chan => $chan,
- host => $host,
- logging => $logging,
- loglevel => $loglevel,
- port => $port,
- tls => $tls,
+ chan => $chan || $DEFAULT_CHAN,
+ host => $host || $DEFAULT_HOST,
+ port => $port || $DEFAULT_PORT,
+ tls => $tls || $DEFAULT_TLS,
},
- {
- ball => \@ball,
- hellos => \@hellos,
- quotes => \@quotes,
- };
+ [
+ \@ball,
+ \@helo,
+ \@quot,
+ ];
}
my ($opts, $lists) = init();
+
while (1) {
- # start the connection
- my $sock;
+ my ($sock, $addr);
+
+ $addr = "$opts->{'host'}:$opts->{'port'}";
if ($opts->{'tls'}) {
- if (not $sock = IO::Socket::SSL->new(
- Domain => AF_INET,
- Timeout => $CONNECT_TIMEOUT,
- Type => SOCK_STREAM,
- PeerHost => $opts->{'host'},
- PeerPort => $opts->{'port'},
- )) {
- logger($opts, 'error', "can't open socket: ${SSL_ERROR}");
- $sock = undef;
- }
+ $sock = IO::Socket::SSL->new(PeerAddr => $addr,
+ Timeout => $CONNECT_TIMEOUT);
} else {
- if (not $sock = IO::Socket->new(
- Domain => AF_INET,
- Timeout => $CONNECT_TIMEOUT,
- Type => SOCK_STREAM,
- proto => $opts->{'tcp'},
- PeerHost => $opts->{'host'},
- PeerPort => $opts->{'port'},
- )) {
- logger($opts, 'error', "can't open socket: ${IO::Socket::errstr}");
- $sock = undef;
- }
+ $sock = IO::Socket::INET->new(PeerAddr => $addr,
+ Timeout => $CONNECT_TIMEOUT);
}
if ($sock) {
- # set user, real, and nick, then join
- out($sock, $opts, "USER ${USER} * * :${REAL}");
- out($sock, $opts, "NICK ${NICK}");
- out($sock, $opts, "JOIN $opts->{'chan'}");
- # main loop
- evasdrop($sock, $opts, $lists);
- # end session and sleep a bit before reconnecting
- out($sock, $opts, 'QUIT');
- if ($opts->{'tls'}) {
- close($sock);
- } else {
- $sock->close();
- }
+ my $s;
+
+ $s = IO::Select->new($sock);
+ sendmsg($s, "USER ${MYUSER} * * :${MYREAL}");
+ sendmsg($s, "NICK ${MYNICK}");
+ sendmsg($s, "WHO ${MYNICK}");
+ sendmsg($s, "JOIN $opts->{'chan'}");
+ evasdrop($s, $opts->{'host'}, $opts->{'chan'}, $lists);
+ sendmsg($s, 'QUIT');
+ $sock->close();
+ } else {
+ logger(LOG_ERROR, "cannot make socket: ${IO::Socket::errstr}");
}
- logger($opts, 'error', "reconnecting in ${RECONNECT_TIME} seconds...");
- sleep $RECONNECT_TIME;
+ logger(LOG_WARN, "reconnecting in ${RECONN_SLEEP} seconds...");
+ sleep $RECONN_SLEEP;
}
blob - ba4adaa06dc295c1d26e38ce56f813277ab7a55c
blob + eaf9aac6ce92b0a5947d6622ac77a092467bcd42
--- matabot.8
+++ matabot.8
.
.Sh SYNOPSIS
.Nm matabot
-.Op Fl tlv
+.Op Fl d | v
.Op Fl H Ar path
.Op Fl b Ar path
.Op Fl j Ar join
Load the hellos file from
.Ar path
.Po default: Pa /usr/local/share/matabot/hellos Pc Ns .
+.It Fl d
+Produce debugging output (logs irc messages and warnings in addition to errors).
.It Fl b Ar path
Load the 8ball file from
.Ar path
.Ar channel
(default: testmatabot).
Don't include the leading #.
-.It Fl l
-Log errors to stderr.
.It Fl p Ar port
Connect to
.Ar port
.It Fl t
Turn on TLS.
.It Fl v
-Produce more verbose output (logs all irc events in addition to errors).
+Produce verbose output (logs warnings in addition to errors).
.El
.Sh COMMANDS
Bot can do some tricks (non-exhaustive, or it won't be funny):
Stay prayed up!!
.It MATABOT I LOVE U!!!
Love the boy.
-.It thank you mata_bot!!
+.It thank you, mata_bot!!
Thank your future master.
-.It mata_boi: Who's the good boy?? (or boi, girl, bot, etc.).
+.It mata_boi: Who's the good boy?? (or boi, girl, bot, etc.)
Praise your future master.
.It mata_bot, hru?
Ask him how he's doin.
(He can't hear you if you don't
.Sq \&?
him :c).
-.It mata_bot, good boy! (or boi, girl, bot, etc.).
+.It mata_bot, good boy! (or boi, girl, bot, etc.)
Praise your future master.
+.It mata_boi: wb!!
+Give him attention.
.It hi, mata_boy!
Say hi to the boy
+.It mataboi: tell me more about allah (or god)
+Ask him to recite verses from abrahamic religious scripture!!
.It noodle -> matabot: clean your room!
-(when sent by noodle) issue direct commands to the boy
-.It .../mata_?bo[ity]/i...
+(When sent by noodle) issue direct commands to the boy
+.It yesterday matabot told me the funniest joke! we're besties!!
Mention him! This boy talks back!?
.El
.Sh FILES
Typical invocation
.Po use these flags in your Pa /etc/rc.conf.local Pc Ns :
.Pp
-.Dl $ matabot -lth irc.server.tld -j analognowhere -p 6697
+.Dl $ matabot -th irc.server.tld -j analognowhere -p 6697
.Pp
Test on a local ircd with verbose logging turned on.
(No TLS):
.Pp
-.Dl $ matabot -lv
+.Dl $ matabot -d
.
.Sh SEE ALSO
.Xr perl 1 ,
(It's hard-coded.
Sorry).
.Sh BUGS
-The bot cannot detach from terminal yet to become a daemon.
+The bot cannot detach from the terminal yet to become a daemon.
daemon-izing is handled in the rc service script.
