matabot.pl (12887B)
1 #!/usr/bin/perl 2 use v5.42; 3 4 use HTTP::Tiny; 5 use IO::Select; 6 use IO::Socket qw(AF_INET SOCK_STREAM); 7 use IO::Socket::SSL; 8 9 $SIG{PIPE} = "IGNORE"; 10 11 use constant { 12 LOG_ERROR => 0, 13 LOG_WARN => 1, 14 LOG_DEBUG => 2, 15 CONNECT_TIMEOUT => 60, 16 CRLF => 2, # RFC 2812 17 DEFAULT_PORT => 6667, 18 DEFAULT_RSS => 0, 19 DEFAULT_TLS => 0, 20 HOSTMAX => 63, # RFC 2812 21 IRCMAX => 512, 22 LAG_CHECK_TIME => 120, 23 MAX_LAG => 300, 24 NBIBLE => 31102, 25 NQURAN => 6348, 26 RECONN_SLEEP => 60, 27 RSS_CHECK_TIME => 3600, 28 SOCK_TIMEOUT => 10, 29 }; 30 my $DEFAULT_CHAN = '#testmatabot'; 31 my $DEFAULT_HOST = 'localhost'; 32 my $DEFAULT_PATH_BALL = '/usr/local/share/matabot/ball'; 33 my $DEFAULT_PATH_HELO = '/usr/local/share/matabot/hellos'; 34 my $DEFAULT_PATH_QUOT = '/usr/local/share/matabot/quotes'; 35 my $FCUTE = '[>.<]'; 36 my $FDEAD = '[x~x]'; 37 my $FFLIP = 't[-_-t]'; 38 my $FGLAD = '[^_^]'; 39 my $FNORM = '[._.]'; 40 my $FSING = '[^=^]'; 41 my $MOM = 'noodle'; 42 my $MYNICK = 'mata_bot'; 43 my $MYREAL = 'death to technomage!!'; 44 my $MYUSER = 'mata_bot_beta4'; 45 my $NICKRE = qr/mata_?bo[ity]+/i; 46 my $RSSLINK = 'https://analognowhere.com/feed/rss.xml'; 47 my $RSSMEM_PATH = 'rss'; 48 49 sub randint { 50 my($min, $max) = @_; 51 52 return $min if $min == $max; 53 ($min, $max) = ($max, $min) if $min > $max; 54 return $min + int rand(1 + $max - $min); 55 } 56 57 sub strip { 58 my $s = shift; 59 return trim($s =~ tr/\0\r\n//dr); 60 } 61 62 sub replycmd { 63 my ($ball, $helo, $nick, $content) = @_; 64 my ($ismom, $reply); 65 66 $nick = 'mother' if $ismom = $nick eq $MOM; 67 $_ = $content; 68 if (/\b{wb}([1-9][0-9]*)?d([1-9][0-9]*)\b{wb}/) { 69 my ($ndice, $nface, $n, $roll); 70 71 ($ndice, $nface) = ($1 // 1, $2); 72 $n = randint($ndice, $ndice*$nface); 73 $roll = ($ndice > 1 ? $ndice : '') . 'd' . $nface; 74 $reply = "${nick} rolled a ${roll} and got ${n}! ${FGLAD}"; 75 } elsif (/pray/i) { 76 $reply = "Stay prayed up!! ${FCUTE}"; 77 } elsif (not $ismom and /\b{wb}bru[hv]+\b{wb}/i) { 78 $reply = "Did i stutter? ${FNORM}"; 79 } elsif (not $ismom and /\b{wb}f+(u?ck+)? *(yo)?u+\b{wb}/in) { 80 $reply = $FFLIP; 81 } elsif (/\b{wb}i+ *l+(ove+)? *(you+|y+|u+)\b{wb}|<3/in) { 82 $reply = "<3 ${FGLAD}"; 83 } elsif (/(thanks+|thx+|thank +(yo)?u+)( *a+ *lot+)?/in) { 84 $reply = "You're welcome, ${nick}! ${FGLAD}"; 85 } elsif (/ 86 who(('|\s+i)?s+)?\s+(a|the)+\s+goo+d+\s+(bo+[ity]+o*|gi+r+l+(i+e+)?) 87 /inx) { 88 $reply = "Me! ${FCUTE}"; 89 } elsif (/ 90 h(ow+)?\s*(are+|r+)\s*(you+|yo+|u+)(\s+doing+)?(\s+today+)?| 91 how('|\si|)s+\s+(it+\s+going+|life+|everything+) 92 /inx) { 93 $reply = "I feel fantaaaastic... hey, hey, hey! ${FSING}"; 94 } elsif (/ 95 \b{wb}( 96 what('|\si|)s+\s*(up+|happening+|cracking+)| 97 (was)?sup+ 98 )\b{wb} 99 /inx) { 100 $reply = "Looking for technomage, and you? ${FNORM}"; 101 } elsif (/\?$/) { 102 $reply = "$ball->[rand @$ball] ${FCUTE}"; 103 } elsif (/ 104 \b{wb}( 105 goo+d+\s*(bo+[ity]+o*|gir(l+|lie+))| 106 w(elcome+)?\s*(b+|back+) 107 )\b{wb} 108 /inx) { 109 $reply = "Thank you, ${nick}! ${FGLAD}"; 110 } elsif (/ 111 \b{wb}( 112 (a[ls]+-?)?sala+m+u*\s*['3a]lai+kum+u*| 113 ay+| 114 g('day+|oo+d\s+(day+|morning+|afternoo+n+|evening+))| 115 greetings+| 116 h(([aeo](i+|llo+)|ey+|i+(ya+)?)(\s+there+)?|owdy+)| 117 hail+| 118 (morn|even)ings+| 119 noo+nafters+| 120 oi+| 121 salutations+| 122 well+\s+met+| 123 yo+ 124 )\b{wb} 125 /inx) { 126 $reply = "$helo->[rand @$helo], ${nick}! ${FGLAD}"; 127 } elsif (/a+l{2,}a+h|g[o-]d/i) { 128 my ($book, $n, $r); 129 130 $book = $& =~ /^a/ ? 'quran' : 'bible'; 131 $n = randint(1, $book eq 'quran' ? NQURAN : NBIBLE); 132 $r = HTTP::Tiny->new->get("https://triapul.cz/files/${book}/${n}"); 133 if ($r->{success}) { 134 $reply = strip($r->{content}); 135 } elsif ($book eq 'quran') { 136 $reply = "Allah will not any answer prayers until the server fixes it's polytheist ways!! ${FCUTE}"; 137 } else { 138 $reply = "God is Dead!! ${FCUTE}"; 139 } 140 } elsif ($ismom) { 141 $reply = "Done, mother! ${FGLAD}"; 142 } else { 143 $reply = "\1ACTION leans over and places its hand near its antenna. \"HUUH?\" ${FNORM}\1"; 144 } 145 return $reply; 146 } 147 148 sub replyhil { 149 my ($quotes, $nick, $msg) = @_; 150 151 if ($nick eq $MOM) { 152 return "Yes, mother? ${FGLAD}"; 153 } elsif ($msg =~ /^${NICKRE}\W*$/) { 154 return "${FNORM} ?"; 155 } else { 156 return "$quotes->[rand @$quotes] ${FNORM}"; 157 } 158 } 159 160 sub respond { 161 state %lastmsg; 162 my ($nick, $msg, ($ball, $helo, $quot)) = @_; 163 my $reply; 164 165 $reply = ''; 166 $_ = $msg; 167 if (m,\b{wb}s/([^/]+)/([^/]*)(?:/([gi]*))?,) { 168 # chat s/// 169 my ($didsub, $imod, $mods, $regex, $retext, $repl); 170 171 $lastmsg{$nick} or return ''; 172 ($retext, $repl, $mods) = ($1, $2, $3 // ''); 173 $imod = $mods =~ /i/ ? 'i' : ''; 174 eval { $regex = qr/(?$imod:$retext)/ } or return ''; 175 if ($mods =~ /g/) { 176 $didsub = $lastmsg{$nick} =~ s/$regex/$repl/g; 177 } else { 178 $didsub = $lastmsg{$nick} =~ s/$regex/$repl/; 179 } 180 $reply = "${nick} meant to say: $lastmsg{$nick}" if $didsub; 181 return $reply; 182 } 183 $lastmsg{$nick} = $msg; 184 if (m,(?:watch\?v=|youtu.be/)([a-zA-Z0-9_-]+),) { 185 # post youtube video title from ID 186 my ($id, $q, $r); 187 188 $id = $1; 189 $q = "?s=https%3A//youtube.com/watch%3Fv%3D${1}&o=relevance"; 190 $r = HTTP::Tiny->new->get("https://fuyt.lab8.cz/${q}"); 191 unless ($r->{success}) { 192 return "${1}: $r->{status} $r->{reason}! ${FDEAD}"; 193 } 194 unless (length $r->{content}) { 195 return "${1}: empty HTTP response! ${FDEAD}"; 196 } 197 unless ($r->{content} =~ m, 198 <span\sclass="title"> 199 <a\shref="https://www\.youtube\.com/watch\?v=${id}" 200 \saccesskey="0">([^<]+)</a> 201 ,ix) { 202 return "${1}: no video matching ID found! ${FDEAD}"; 203 } 204 $reply = 'YouTube: ' . strip($1); 205 } elsif ( 206 m,https?://([^ /]*[^ ./0-9][^ /]*\.)+[^ /]*[^ ./0-9][^ /]*(/[^ ]*)?,n 207 ) { 208 # post website title for text/html or mimetype otherwise 209 my ($r, $url); 210 211 $url = $&; 212 $r = HTTP::Tiny->new->head($url); 213 unless ($r->{success}) { 214 return "HEAD ${url}: $r->{status} $r->{reason}! ${FDEAD}"; 215 } 216 unless ($r->{headers}->{'content-type'}) { 217 return "HEAD ${url}: empty MIME type! ${FDEAD}"; 218 } 219 unless ($r->{headers}->{'content-type'} =~ m,text/html,) { 220 return "File: $r->{headers}->{'content-type'}"; 221 } 222 $r = HTTP::Tiny->new->get($url); 223 unless ($r->{success}) { 224 return "GET ${url}: $r->{status} $r->{reason}! ${FDEAD}"; 225 } 226 unless ($r->{content}) { 227 return "GET ${url}: empty HTTP response! ${FDEAD}"; 228 } 229 unless ($r->{content} =~ m,<title[^>]*>([^<]+)</title[^>]*>,i) { 230 return "GET ${url}: no title found! ${FDEAD}"; 231 } 232 $reply = 'Title: ' . strip($1); 233 } elsif (/^ *${NICKRE}[:, ] *(\W?[^ \W].*)$/ 234 or /^ *([^ ].*)[, ] *${NICKRE}([\W\d]*)$/) { 235 $reply = replycmd($ball, $helo, $nick, $1 . ($2//'')); 236 } elsif (/\b${NICKRE}\b/) { 237 $reply = replyhil($quot, $nick, $msg); 238 } 239 return $reply; 240 } 241 242 sub logger { 243 state $loglevel = LOG_ERROR; 244 my ($level, $msg) = @_; 245 246 if ($msg) { 247 say STDERR $msg if $loglevel >= $level 248 } else { 249 $loglevel = $level; 250 } 251 } 252 253 sub sendmsg { 254 my ($s, $msg) = @_; 255 my $sock; 256 257 $! = 0; 258 unless (($sock) = $s->can_write(SOCK_TIMEOUT)) { 259 if ($!) { logger(LOG_ERROR, $!) } 260 else { logger(LOG_WARN, "sock not ready to write") } 261 return 0; 262 } 263 print $sock $msg . "\r\n"; 264 logger(LOG_DEBUG, "<- " . $msg); 265 return 1; 266 } 267 268 sub recvmsg { 269 state $buf = ''; 270 my $s = shift; 271 272 while(1) { 273 my ($line, $sock); 274 275 $_ = $buf; 276 if (not length) { 277 } elsif (/\A([^\0\n\r]+)\r\n(.+)?\z/s) { 278 logger(LOG_DEBUG, "-> " . $1); 279 $buf = $2 // ''; 280 return $1; 281 } elsif (/\n\n|\n\r|\r\r|\r[^\n\r]|[^\n\r]\n/) { 282 logger(LOG_ERROR, 'recieved a malformed message'); 283 return undef; 284 } 285 # read a line 286 $! = 0; 287 unless (($sock) = $s->can_read(SOCK_TIMEOUT)) { 288 if ($!) { 289 logger(LOG_ERROR, $!); 290 return undef; 291 } 292 return ''; 293 } 294 unless (length($line = <$sock>) > 0) { 295 if ($!) { logger(LOG_ERROR, $!) } 296 else { logger(LOG_WARN, 'recieved an empty message') } 297 return undef; 298 } 299 $buf .= $line; 300 } 301 } 302 303 sub sendnews { 304 state $lastlink; 305 my $rssmem = shift; 306 my ($homepage, $r); 307 my (@matches, @replies); 308 309 $r = HTTP::Tiny->new->get($RSSLINK); 310 unless ($r->{success}) { 311 logger(LOG_WARN, 'GET ${RSSLINK}: $r->{status} $r->{reason}'); 312 return (); 313 } 314 unless (length $r->{content}) { 315 logger(LOG_WARN, 'GET ${RSSLINK}: empty HTTP response'); 316 return (); 317 } 318 unless (defined($lastlink)) { 319 seek($rssmem, 0, 0); 320 chomp($lastlink = <$rssmem>); 321 } 322 $homepage = ($r->{content} =~ m,<channel>.*?<link>([^<]+)</link>,s) ? $1 : 'website'; 323 while ($r->{content} =~ m,\G.*?<item>.*?<title>([^<]+)</title>.*?<link>([^<]+)</link>.*?</item>,gs) { 324 push @matches, {title => $1, link => $2}; 325 } 326 if (@matches) { 327 my $i; 328 329 if (defined($lastlink)) { 330 for ($i = 0; $i < @matches; $i++) { 331 last if $matches[$i]->{'link'} eq $lastlink; 332 } 333 } else { 334 $i = @matches; 335 } 336 for ($i--; $i >= 0; $i--) { 337 push @replies, "RSS: $matches[$i]->{'link'} | $matches[$i]->{'title'}"; 338 if ($i > 2) { 339 push @replies, "RSS: found " . ($i-1) . " new items in between. Visit ${homepage} for more..."; 340 $i = 1; 341 } 342 } 343 truncate($rssmem, 0); 344 seek($rssmem, 0, 0); 345 say $rssmem ($lastlink = $matches[0]->{'link'}); 346 $rssmem->flush; 347 } 348 return @replies; 349 } 350 351 sub evasdrop { 352 my ($s, $rssmem, $lists, ($chan, $host, $rss)) = @_; 353 my ($firstrss, $msgmax, $msgtime, $pingsent, $pingtime, $priv, $rsstime); 354 355 $firstrss = 1; 356 $pingsent = 0; 357 $priv = "PRIVMSG ${chan} :"; 358 $msgmax = IRCMAX - length(":${MYNICK}!~${MYUSER}\@ ${priv}") 359 - HOSTMAX - CRLF; # conservative max message length heuristic 360 $rsstime = $msgtime = $pingtime = time; 361 while (1) { 362 if ($pingsent) { 363 if (time - $pingtime > MAX_LAG) { 364 # leave if we don't get ponged back on time 365 logger(LOG_WARN, 'server pong reply timed out'); 366 return; 367 } 368 } elsif (time - $msgtime > LAG_CHECK_TIME) { 369 # ping server every once in a while 370 sendmsg($s, "PING :${host}"); 371 $pingsent = 1; 372 $pingtime = time; 373 } 374 if ($rss and ($firstrss || time - $rsstime > RSS_CHECK_TIME)) { 375 foreach (sendnews($rssmem)) { 376 sendmsg($s, $priv . substr($_,0,$msgmax)); 377 } 378 $rsstime = time; 379 $firstrss = 0 if $firstrss; 380 } 381 defined($_ = recvmsg($s)) or return; 382 next if not length; 383 $msgtime = time; 384 if (/^PING :([^ ]+)$/) { 385 sendmsg($s, 'PONG :' . $1); 386 } elsif (/^:[^ ]+ PONG/) { 387 $pingsent = 0; 388 } elsif ( 389 /^:[^ ]+ 352 ${MYNICK} [^ ]+ ([^ ]+) ([^ ]+) [^ ]+ (${MYNICK})/ 390 ) { 391 # refine maximum message length heuristic 392 $msgmax = IRCMAX - length(":${3}!${1}\@${2} ${priv}") 393 - CRLF; 394 } elsif (/^:([^ !#&][^ !]*)![^ \@]+\@[^ ]+ ${priv}(.+)$/) { 395 # respond to chan message 396 my ($r, $len); 397 398 $r = respond($1, $2, @$lists); 399 if ($len = length($r)) { 400 $r = substr($r,0,$msgmax-1).'-' if $len>$msgmax; 401 sendmsg($s, $priv . $r); 402 } 403 } 404 } 405 } 406 407 sub usage { 408 say STDERR "usage: ${0} [-d|-v] [-r] [-t] [-b path] [-e path] [-h host] [-j join] [-p port] [-q path]"; 409 exit 1; 410 } 411 412 sub init { 413 my ($path_ball, $path_helo, $path_quot); 414 my $rssmem; 415 my %opts; 416 417 @_ = @ARGV; 418 while (@_) { 419 $_ = shift; 420 if (/^-d$/) { logger(LOG_DEBUG) } 421 elsif (/^-r$/) { $opts{'rss'} = 1 } 422 elsif (/^-t$/) { $opts{'tls'} = 1 } 423 elsif (/^-v$/) { logger(LOG_WARN) } 424 elsif (@_ < 1) { usage() } 425 elsif (/^-b$/) { $path_ball = shift } 426 elsif (/^-e$/) { $path_helo = shift } 427 elsif (/^-h$/) { $opts{'host'} = shift } 428 elsif (/^-j$/) { $opts{'chan'} = '#' . shift } 429 elsif (/^-p$/) { $opts{'port'} = shift } 430 elsif (/^-q$/) { $path_quot = shift } 431 else { usage() } 432 } 433 $opts{'chan'} //= $DEFAULT_CHAN; 434 $opts{'host'} //= $DEFAULT_HOST; 435 $opts{'port'} //= DEFAULT_PORT; 436 $opts{'rss'} //= DEFAULT_RSS; 437 $opts{'tls'} //= DEFAULT_TLS; 438 open(my $ball_file, '<', $path_ball // $DEFAULT_PATH_BALL) 439 or die "couldn't open ${path_ball}: $!"; 440 chomp(my @ball = <$ball_file>); 441 close $ball_file or die "${ball_file}: $!"; 442 open(my $helo_file, '<', $path_helo // $DEFAULT_PATH_HELO) 443 or die "couldn't open ${path_helo}: $!"; 444 chomp(my @helo = <$helo_file>); 445 close $helo_file or die "${helo_file}: $!"; 446 open(my $quot_file, '<', $path_quot // $DEFAULT_PATH_QUOT) 447 or die "couldn't open ${path_quot}: $!"; 448 chomp(my @quot = <$quot_file>); 449 close $quot_file or die "${quot_file}: $!"; 450 if ($opts{'rss'}) { 451 open($rssmem, '+>>', $RSSMEM_PATH) 452 || die "couldn't open ${RSSMEM_PATH}: $!"; 453 } 454 return $rssmem, \%opts, [ 455 \@ball, 456 \@helo, 457 \@quot, 458 ]; 459 } 460 461 my ($rssmem, $opts, $lists) = init(); 462 463 while (1) { 464 my ($sock, $addr); 465 466 $addr = "$opts->{'host'}:$opts->{'port'}"; 467 if ($opts->{'tls'}) { 468 $sock = IO::Socket::SSL->new(PeerAddr => $addr, 469 Timeout => CONNECT_TIMEOUT); 470 } else { 471 $sock = IO::Socket::INET->new(PeerAddr => $addr, 472 Timeout => CONNECT_TIMEOUT); 473 } 474 if ($sock) { 475 my $s; 476 477 $s = IO::Select->new($sock); 478 sendmsg($s, "USER ${MYUSER} * * :${MYREAL}"); 479 sendmsg($s, "NICK ${MYNICK}"); 480 sendmsg($s, "WHO ${MYNICK}"); 481 sendmsg($s, "JOIN $opts->{'chan'}"); 482 evasdrop($s, $rssmem, $lists, @$opts{'chan', 'host', 'rss'}); 483 sendmsg($s, 'QUIT'); 484 $sock->close(); 485 } else { 486 logger(LOG_ERROR, "cannot make socket: ${IO::Socket::errstr}"); 487 } 488 logger(LOG_WARN, "reconnecting in ".RECONN_SLEEP." seconds..."); 489 sleep RECONN_SLEEP; 490 }