commit 333e51c3107833915c41cfcd0939b6ae6faffe2d from: noodle date: Wed Dec 24 20:18:49 2025 UTC The Grand Refactor:tm: (Sorry!!) kill useless code, abbreviate, redo logging, tighten security, and make matabot a bit smarter. commit - 7317d784aaa81fab85efb43c0ce240c22bb063bb commit + 333e51c3107833915c41cfcd0939b6ae6faffe2d blob - 471f8e0dbf91ea52a60c8cb78ed77f6c7660a78f blob + 2809d81a4a80f7a0d805fb323e972d3f1680b4da --- mata_bot.pl +++ mata_bot.pl @@ -1,445 +1,416 @@ #!/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, + + ([^<]+) + ,ix) { + return "${1}: no video matching ID found! ${FDEAD}"; } - my $body = $response->{content}; - if ($body =~ m,([^<]+),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,]*>([^<]+)]*>,i) { + return "GET ${url}: no title found! ${FDEAD}"; } - my $body = $response->{content}; - if ($body =~ m,]*>([^<]+)]*>,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 @@ -8,7 +8,7 @@ . .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 @@ -31,6 +31,8 @@ The options are as follows: 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 @@ -44,8 +46,6 @@ Join .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 @@ -57,7 +57,7 @@ Load the quotes file from .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): @@ -79,9 +79,9 @@ He's a dungeon master too!! 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. @@ -92,13 +92,17 @@ Ask him your burning questions... (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 @@ -125,12 +129,12 @@ comic. 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 , @@ -178,5 +182,5 @@ Noodle (noodle) is the only person in chat who can giv (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.