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