commit bb2ae5913b6b8c7eccc4c6311a0cdcaa5f2d9a78 from: noodle date: Sun Apr 5 02:56:30 2026 UTC change script and project name to matabot.pl and matabot.git, respectively commit - 5169add85db2bafc6dc680db0206d6b6a499dd95 commit + bb2ae5913b6b8c7eccc4c6311a0cdcaa5f2d9a78 blob - 5c3d3476a36709b2c9416966883bf1ea2eb71101 blob + 41eead2d82ba34a55c4ff96c32f124ec02c4ea10 --- Makefile +++ Makefile @@ -11,13 +11,13 @@ rc_script: rc_script.in clean: rm -f rc_script -install: mata_bot.pl matabot.8 rc_script +install: matabot.pl matabot.8 rc_script install -d ${DISTDIR}${PREFIX}/sbin install -d ${DISTDIR}${PREFIX}/share install -d ${DISTDIR}${MANDIR}/man8 install -d ${DISTDIR}${SHAREDIR}/matabot install -d ${DISTDIR}${RCDIR} - install mata_bot.pl ${DESTDIR}${PREFIX}/sbin/matabot + install matabot.pl ${DESTDIR}${PREFIX}/sbin/matabot install ball ${DESTDIR}${SHAREDIR}/matabot/ball install hellos ${DESTDIR}${SHAREDIR}/matabot/hellos install quotes ${DESTDIR}${SHAREDIR}/matabot/quotes blob - 7ae4d09317a961dd6028db9384ccd6f4abd07b84 (mode 755) blob + /dev/null --- mata_bot.pl +++ /dev/null @@ -1,488 +0,0 @@ -#!/usr/bin/perl -use v5.42; - -use HTTP::Tiny; -use IO::Select; -use IO::Socket qw(AF_INET SOCK_STREAM); -use IO::Socket::SSL; - -use constant { - LOG_ERROR => 0, - LOG_WARN => 1, - LOG_DEBUG => 2, - CONNECT_TIMEOUT => 60, - CRLF => 2, # RFC 2812 - DEFAULT_PORT => 6667, - DEFAULT_RSS => 0, - DEFAULT_TLS => 0, - HOSTMAX => 63, # RFC 2812 - IRCMAX => 512, - LAG_CHECK_TIME => 120, - MAX_LAG => 300, - NBIBLE => 31102, - NQURAN => 6348, - RECONN_SLEEP => 60, - RSS_CHECK_TIME => 3600, - SOCK_TIMEOUT => 10, -}; -my $DEFAULT_CHAN = '#testmatabot'; -my $DEFAULT_HOST = 'localhost'; -my $DEFAULT_PATH_BALL = '/usr/local/share/matabot/ball'; -my $DEFAULT_PATH_HELO = '/usr/local/share/matabot/hellos'; -my $DEFAULT_PATH_QUOT = '/usr/local/share/matabot/quotes'; -my $FCUTE = '[>.<]'; -my $FDEAD = '[x~x]'; -my $FFLIP = 't[-_-t]'; -my $FGLAD = '[^_^]'; -my $FNORM = '[._.]'; -my $FSING = '[^=^]'; -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 $RSSLINK = 'https://analognowhere.com/feed/rss.xml'; -my $RSSMEM_PATH = 'rss'; - -sub randint { - my($min, $max) = @_; - - return $min if $min == $max; - ($min, $max) = ($max, $min) if $min > $max; - return $min + int rand(1 + $max - $min); -} - -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, $book eq 'quran' ? NQURAN : NBIBLE); - $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 = "God is Dead!! ${FCUTE}"; - } - } elsif ($ismom) { - $reply = "Done, mother! ${FGLAD}"; - } else { - $reply = "\1ACTION leans over and places its hand near its antenna. \"HUUH?\" ${FNORM}\1"; - } - return $reply; -} - -sub replyhil { - my ($quotes, $nick, $msg) = @_; - - if ($nick eq $MOM) { - return "Yes, mother? ${FGLAD}"; - } elsif ($msg =~ /^${NICKRE}\W*$/) { - return "${FNORM} ?"; - } else { - return "$quotes->[rand @$quotes] ${FNORM}"; - } -} - -sub respond { - state %lastmsg; - my ($nick, $msg, ($ball, $helo, $quot)) = @_; - my $reply; - - $reply = ''; - $_ = $msg; - if (m,\b{wb}s/([^/]+)/([^/]*)(?:/([gi]*))?,) { - # chat s/// - 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/) { - $didsub = $lastmsg{$nick} =~ s/$regex/$repl/g; - } else { - $didsub = $lastmsg{$nick} =~ s/$regex/$repl/; - } - $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}"; - } - unless (length $r->{content}) { - return "${1}: empty HTTP response! ${FDEAD}"; - } - unless ($r->{content} =~ m, - - ([^<]+) - ,ix) { - return "${1}: no video matching ID found! ${FDEAD}"; - } - $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}"; - } - unless ($r->{headers}->{'content-type'}) { - return "HEAD ${url}: empty MIME type! ${FDEAD}"; - } - unless ($r->{headers}->{'content-type'} =~ m,text/html,) { - return "File: $r->{headers}->{'content-type'}"; - } - $r = HTTP::Tiny->new->get($url); - unless ($r->{success}) { - return "GET ${url}: $r->{status} $r->{reason}! ${FDEAD}"; - } - unless ($r->{content}) { - return "GET ${url}: empty HTTP response! ${FDEAD}"; - } - unless ($r->{content} =~ m,]*>([^<]+)]*>,i) { - return "GET ${url}: no title found! ${FDEAD}"; - } - $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 $reply; -} - -sub logger { - state $loglevel = LOG_ERROR; - my ($level, $msg) = @_; - - if ($msg) { - say STDERR $msg if $loglevel >= $level - } else { - $loglevel = $level; - } -} - -sub sendmsg { - my ($s, $msg) = @_; - my $sock; - - $! = 0; - unless (($sock) = $s->can_write(SOCK_TIMEOUT)) { - if ($!) { logger(LOG_ERROR, $!) } - else { logger(LOG_WARN, "sock not ready to write") } - return 0; - } - print $sock $msg . "\r\n"; - logger(LOG_DEBUG, "<- " . $msg); - return 1; -} - -sub recvmsg { - state $buf = ''; - my $s = shift; - - while(1) { - my ($line, $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 line - $! = 0; - unless (($sock) = $s->can_read(SOCK_TIMEOUT)) { - if ($!) { - logger(LOG_ERROR, $!); - return undef; - } - return ''; - } - unless (length($line = <$sock>) > 0) { - if ($!) { logger(LOG_ERROR, $!) } - else { logger(LOG_WARN, 'recieved an empty message') } - return undef; - } - $buf .= $line; - } -} - -sub sendnews { - state $lastlink; - my $rssmem = shift; - my ($homepage, $r); - my (@matches, @replies); - - $r = HTTP::Tiny->new->get($RSSLINK); - unless ($r->{success}) { - logger(LOG_WARN, 'GET ${RSSLINK}: $r->{status} $r->{reason}'); - return (); - } - unless (length $r->{content}) { - logger(LOG_WARN, 'GET ${RSSLINK}: empty HTTP response'); - return (); - } - unless (defined($lastlink)) { - seek($rssmem, 0, 0); - chomp($lastlink = <$rssmem>); - } - $homepage = ($r->{content} =~ m,.*?([^<]+),s) ? $1 : 'website'; - while ($r->{content} =~ m,\G.*?.*?([^<]+).*?([^<]+).*?,gs) { - push @matches, {title => $1, link => $2}; - } - if (@matches) { - my $i; - - if (defined($lastlink)) { - for ($i = 0; $i < @matches; $i++) { - last if $matches[$i]->{'link'} eq $lastlink; - } - } else { - $i = @matches; - } - for ($i--; $i >= 0; $i--) { - push @replies, "RSS: $matches[$i]->{'link'} | $matches[$i]->{'title'}"; - if ($i > 2) { - push @replies, "RSS: found " . ($i-1) . " new items in between. Visit ${homepage} for more..."; - $i = 1; - } - } - truncate($rssmem, 0); - seek($rssmem, 0, 0); - say $rssmem ($lastlink = $matches[0]->{'link'}); - $rssmem->flush; - } - return @replies; -} - -sub evasdrop { - my ($s, $rssmem, $lists, ($chan, $host, $rss)) = @_; - my ($firstrss, $msgmax, $msgtime, $pingsent, $pingtime, $priv, $rsstime); - - $firstrss = 1; - $pingsent = 0; - $priv = "PRIVMSG ${chan} :"; - $msgmax = IRCMAX - length(":${MYNICK}!~${MYUSER}\@ ${priv}") - - HOSTMAX - CRLF; # conservative max message length heuristic - $rsstime = $msgtime = $pingtime = time; - while (1) { - if ($pingsent) { - if (time - $pingtime > MAX_LAG) { - # leave if we don't get ponged back on time - logger(LOG_WARN, 'server pong reply timed out'); - return; - } - } elsif (time - $msgtime > LAG_CHECK_TIME) { - # ping server every once in a while - sendmsg($s, "PING :${host}"); - $pingsent = 1; - $pingtime = time; - } - if ($rss and ($firstrss || time - $rsstime > RSS_CHECK_TIME)) { - foreach (sendnews($rssmem)) { - sendmsg($s, $priv . substr($_,0,$msgmax)); - } - $rsstime = time; - $firstrss = 0 if $firstrss; - } - defined($_ = recvmsg($s)) or return; - next if not length; - $msgtime = time; - if (/^PING :([^ ]+)$/) { - sendmsg($s, 'PONG :' . $1); - } elsif (/^:[^ ]+ PONG/) { - $pingsent = 0; - } elsif ( - /^:[^ ]+ 352 ${MYNICK} [^ ]+ ([^ ]+) ([^ ]+) [^ ]+ (${MYNICK})/ - ) { - # refine maximum message length heuristic - $msgmax = IRCMAX - length(":${3}!${1}\@${2} ${priv}") - - CRLF; - } elsif (/^:([^ !#&][^ !]*)![^ \@]+\@[^ ]+ ${priv}(.+)$/) { - # respond to chan message - my ($r, $len); - - $r = respond($1, $2, @$lists); - if ($len = length($r)) { - $r = substr($r,0,$msgmax-1).'-' if $len>$msgmax; - sendmsg($s, $priv . $r); - } - } - } -} - -sub usage { - say STDERR "usage: ${0} [-d|-v] [-r] [-t] [-b path] [-e path] [-h host] [-j join] [-p port] [-q path]"; - exit 1; -} - -sub init { - my ($path_ball, $path_helo, $path_quot); - my $rssmem; - my %opts; - - @_ = @ARGV; - while (@_) { - $_ = shift; - if (/^-d$/) { logger(LOG_DEBUG) } - elsif (/^-r$/) { $opts{'rss'} = 1 } - elsif (/^-t$/) { $opts{'tls'} = 1 } - elsif (/^-v$/) { logger(LOG_WARN) } - elsif (@_ < 1) { usage() } - elsif (/^-b$/) { $path_ball = shift } - elsif (/^-e$/) { $path_helo = shift } - elsif (/^-h$/) { $opts{'host'} = shift } - elsif (/^-j$/) { $opts{'chan'} = '#' . shift } - elsif (/^-p$/) { $opts{'port'} = shift } - elsif (/^-q$/) { $path_quot = shift } - else { usage() } - } - $opts{'chan'} //= $DEFAULT_CHAN; - $opts{'host'} //= $DEFAULT_HOST; - $opts{'port'} //= DEFAULT_PORT; - $opts{'rss'} //= DEFAULT_RSS; - $opts{'tls'} //= DEFAULT_TLS; - 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 $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}: $!"; - if ($opts{'rss'}) { - open($rssmem, '+>>', $RSSMEM_PATH) - || die "couldn't open ${RSSMEM_PATH}: $!"; - } - return $rssmem, \%opts, [ - \@ball, - \@helo, - \@quot, - ]; -} - -my ($rssmem, $opts, $lists) = init(); - -while (1) { - my ($sock, $addr); - - $addr = "$opts->{'host'}:$opts->{'port'}"; - if ($opts->{'tls'}) { - $sock = IO::Socket::SSL->new(PeerAddr => $addr, - Timeout => CONNECT_TIMEOUT); - } else { - $sock = IO::Socket::INET->new(PeerAddr => $addr, - Timeout => CONNECT_TIMEOUT); - } - if ($sock) { - 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, $rssmem, $lists, @$opts{'chan', 'host', 'rss'}); - sendmsg($s, 'QUIT'); - $sock->close(); - } else { - logger(LOG_ERROR, "cannot make socket: ${IO::Socket::errstr}"); - } - logger(LOG_WARN, "reconnecting in ".RECONN_SLEEP." seconds..."); - sleep RECONN_SLEEP; -} blob - /dev/null blob + 7ae4d09317a961dd6028db9384ccd6f4abd07b84 (mode 755) --- /dev/null +++ matabot.pl @@ -0,0 +1,488 @@ +#!/usr/bin/perl +use v5.42; + +use HTTP::Tiny; +use IO::Select; +use IO::Socket qw(AF_INET SOCK_STREAM); +use IO::Socket::SSL; + +use constant { + LOG_ERROR => 0, + LOG_WARN => 1, + LOG_DEBUG => 2, + CONNECT_TIMEOUT => 60, + CRLF => 2, # RFC 2812 + DEFAULT_PORT => 6667, + DEFAULT_RSS => 0, + DEFAULT_TLS => 0, + HOSTMAX => 63, # RFC 2812 + IRCMAX => 512, + LAG_CHECK_TIME => 120, + MAX_LAG => 300, + NBIBLE => 31102, + NQURAN => 6348, + RECONN_SLEEP => 60, + RSS_CHECK_TIME => 3600, + SOCK_TIMEOUT => 10, +}; +my $DEFAULT_CHAN = '#testmatabot'; +my $DEFAULT_HOST = 'localhost'; +my $DEFAULT_PATH_BALL = '/usr/local/share/matabot/ball'; +my $DEFAULT_PATH_HELO = '/usr/local/share/matabot/hellos'; +my $DEFAULT_PATH_QUOT = '/usr/local/share/matabot/quotes'; +my $FCUTE = '[>.<]'; +my $FDEAD = '[x~x]'; +my $FFLIP = 't[-_-t]'; +my $FGLAD = '[^_^]'; +my $FNORM = '[._.]'; +my $FSING = '[^=^]'; +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 $RSSLINK = 'https://analognowhere.com/feed/rss.xml'; +my $RSSMEM_PATH = 'rss'; + +sub randint { + my($min, $max) = @_; + + return $min if $min == $max; + ($min, $max) = ($max, $min) if $min > $max; + return $min + int rand(1 + $max - $min); +} + +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, $book eq 'quran' ? NQURAN : NBIBLE); + $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 = "God is Dead!! ${FCUTE}"; + } + } elsif ($ismom) { + $reply = "Done, mother! ${FGLAD}"; + } else { + $reply = "\1ACTION leans over and places its hand near its antenna. \"HUUH?\" ${FNORM}\1"; + } + return $reply; +} + +sub replyhil { + my ($quotes, $nick, $msg) = @_; + + if ($nick eq $MOM) { + return "Yes, mother? ${FGLAD}"; + } elsif ($msg =~ /^${NICKRE}\W*$/) { + return "${FNORM} ?"; + } else { + return "$quotes->[rand @$quotes] ${FNORM}"; + } +} + +sub respond { + state %lastmsg; + my ($nick, $msg, ($ball, $helo, $quot)) = @_; + my $reply; + + $reply = ''; + $_ = $msg; + if (m,\b{wb}s/([^/]+)/([^/]*)(?:/([gi]*))?,) { + # chat s/// + 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/) { + $didsub = $lastmsg{$nick} =~ s/$regex/$repl/g; + } else { + $didsub = $lastmsg{$nick} =~ s/$regex/$repl/; + } + $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}"; + } + unless (length $r->{content}) { + return "${1}: empty HTTP response! ${FDEAD}"; + } + unless ($r->{content} =~ m, + + ([^<]+) + ,ix) { + return "${1}: no video matching ID found! ${FDEAD}"; + } + $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}"; + } + unless ($r->{headers}->{'content-type'}) { + return "HEAD ${url}: empty MIME type! ${FDEAD}"; + } + unless ($r->{headers}->{'content-type'} =~ m,text/html,) { + return "File: $r->{headers}->{'content-type'}"; + } + $r = HTTP::Tiny->new->get($url); + unless ($r->{success}) { + return "GET ${url}: $r->{status} $r->{reason}! ${FDEAD}"; + } + unless ($r->{content}) { + return "GET ${url}: empty HTTP response! ${FDEAD}"; + } + unless ($r->{content} =~ m,]*>([^<]+)]*>,i) { + return "GET ${url}: no title found! ${FDEAD}"; + } + $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 $reply; +} + +sub logger { + state $loglevel = LOG_ERROR; + my ($level, $msg) = @_; + + if ($msg) { + say STDERR $msg if $loglevel >= $level + } else { + $loglevel = $level; + } +} + +sub sendmsg { + my ($s, $msg) = @_; + my $sock; + + $! = 0; + unless (($sock) = $s->can_write(SOCK_TIMEOUT)) { + if ($!) { logger(LOG_ERROR, $!) } + else { logger(LOG_WARN, "sock not ready to write") } + return 0; + } + print $sock $msg . "\r\n"; + logger(LOG_DEBUG, "<- " . $msg); + return 1; +} + +sub recvmsg { + state $buf = ''; + my $s = shift; + + while(1) { + my ($line, $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 line + $! = 0; + unless (($sock) = $s->can_read(SOCK_TIMEOUT)) { + if ($!) { + logger(LOG_ERROR, $!); + return undef; + } + return ''; + } + unless (length($line = <$sock>) > 0) { + if ($!) { logger(LOG_ERROR, $!) } + else { logger(LOG_WARN, 'recieved an empty message') } + return undef; + } + $buf .= $line; + } +} + +sub sendnews { + state $lastlink; + my $rssmem = shift; + my ($homepage, $r); + my (@matches, @replies); + + $r = HTTP::Tiny->new->get($RSSLINK); + unless ($r->{success}) { + logger(LOG_WARN, 'GET ${RSSLINK}: $r->{status} $r->{reason}'); + return (); + } + unless (length $r->{content}) { + logger(LOG_WARN, 'GET ${RSSLINK}: empty HTTP response'); + return (); + } + unless (defined($lastlink)) { + seek($rssmem, 0, 0); + chomp($lastlink = <$rssmem>); + } + $homepage = ($r->{content} =~ m,.*?([^<]+),s) ? $1 : 'website'; + while ($r->{content} =~ m,\G.*?.*?([^<]+).*?([^<]+).*?,gs) { + push @matches, {title => $1, link => $2}; + } + if (@matches) { + my $i; + + if (defined($lastlink)) { + for ($i = 0; $i < @matches; $i++) { + last if $matches[$i]->{'link'} eq $lastlink; + } + } else { + $i = @matches; + } + for ($i--; $i >= 0; $i--) { + push @replies, "RSS: $matches[$i]->{'link'} | $matches[$i]->{'title'}"; + if ($i > 2) { + push @replies, "RSS: found " . ($i-1) . " new items in between. Visit ${homepage} for more..."; + $i = 1; + } + } + truncate($rssmem, 0); + seek($rssmem, 0, 0); + say $rssmem ($lastlink = $matches[0]->{'link'}); + $rssmem->flush; + } + return @replies; +} + +sub evasdrop { + my ($s, $rssmem, $lists, ($chan, $host, $rss)) = @_; + my ($firstrss, $msgmax, $msgtime, $pingsent, $pingtime, $priv, $rsstime); + + $firstrss = 1; + $pingsent = 0; + $priv = "PRIVMSG ${chan} :"; + $msgmax = IRCMAX - length(":${MYNICK}!~${MYUSER}\@ ${priv}") + - HOSTMAX - CRLF; # conservative max message length heuristic + $rsstime = $msgtime = $pingtime = time; + while (1) { + if ($pingsent) { + if (time - $pingtime > MAX_LAG) { + # leave if we don't get ponged back on time + logger(LOG_WARN, 'server pong reply timed out'); + return; + } + } elsif (time - $msgtime > LAG_CHECK_TIME) { + # ping server every once in a while + sendmsg($s, "PING :${host}"); + $pingsent = 1; + $pingtime = time; + } + if ($rss and ($firstrss || time - $rsstime > RSS_CHECK_TIME)) { + foreach (sendnews($rssmem)) { + sendmsg($s, $priv . substr($_,0,$msgmax)); + } + $rsstime = time; + $firstrss = 0 if $firstrss; + } + defined($_ = recvmsg($s)) or return; + next if not length; + $msgtime = time; + if (/^PING :([^ ]+)$/) { + sendmsg($s, 'PONG :' . $1); + } elsif (/^:[^ ]+ PONG/) { + $pingsent = 0; + } elsif ( + /^:[^ ]+ 352 ${MYNICK} [^ ]+ ([^ ]+) ([^ ]+) [^ ]+ (${MYNICK})/ + ) { + # refine maximum message length heuristic + $msgmax = IRCMAX - length(":${3}!${1}\@${2} ${priv}") + - CRLF; + } elsif (/^:([^ !#&][^ !]*)![^ \@]+\@[^ ]+ ${priv}(.+)$/) { + # respond to chan message + my ($r, $len); + + $r = respond($1, $2, @$lists); + if ($len = length($r)) { + $r = substr($r,0,$msgmax-1).'-' if $len>$msgmax; + sendmsg($s, $priv . $r); + } + } + } +} + +sub usage { + say STDERR "usage: ${0} [-d|-v] [-r] [-t] [-b path] [-e path] [-h host] [-j join] [-p port] [-q path]"; + exit 1; +} + +sub init { + my ($path_ball, $path_helo, $path_quot); + my $rssmem; + my %opts; + + @_ = @ARGV; + while (@_) { + $_ = shift; + if (/^-d$/) { logger(LOG_DEBUG) } + elsif (/^-r$/) { $opts{'rss'} = 1 } + elsif (/^-t$/) { $opts{'tls'} = 1 } + elsif (/^-v$/) { logger(LOG_WARN) } + elsif (@_ < 1) { usage() } + elsif (/^-b$/) { $path_ball = shift } + elsif (/^-e$/) { $path_helo = shift } + elsif (/^-h$/) { $opts{'host'} = shift } + elsif (/^-j$/) { $opts{'chan'} = '#' . shift } + elsif (/^-p$/) { $opts{'port'} = shift } + elsif (/^-q$/) { $path_quot = shift } + else { usage() } + } + $opts{'chan'} //= $DEFAULT_CHAN; + $opts{'host'} //= $DEFAULT_HOST; + $opts{'port'} //= DEFAULT_PORT; + $opts{'rss'} //= DEFAULT_RSS; + $opts{'tls'} //= DEFAULT_TLS; + 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 $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}: $!"; + if ($opts{'rss'}) { + open($rssmem, '+>>', $RSSMEM_PATH) + || die "couldn't open ${RSSMEM_PATH}: $!"; + } + return $rssmem, \%opts, [ + \@ball, + \@helo, + \@quot, + ]; +} + +my ($rssmem, $opts, $lists) = init(); + +while (1) { + my ($sock, $addr); + + $addr = "$opts->{'host'}:$opts->{'port'}"; + if ($opts->{'tls'}) { + $sock = IO::Socket::SSL->new(PeerAddr => $addr, + Timeout => CONNECT_TIMEOUT); + } else { + $sock = IO::Socket::INET->new(PeerAddr => $addr, + Timeout => CONNECT_TIMEOUT); + } + if ($sock) { + 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, $rssmem, $lists, @$opts{'chan', 'host', 'rss'}); + sendmsg($s, 'QUIT'); + $sock->close(); + } else { + logger(LOG_ERROR, "cannot make socket: ${IO::Socket::errstr}"); + } + logger(LOG_WARN, "reconnecting in ".RECONN_SLEEP." seconds..."); + sleep RECONN_SLEEP; +}