mata_bot

mata_bot.pl (12975B)

---

 #!/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 $CHUNK_LENGTH = 1024;
 my $CONNECT_TIMEOUT = 60;
 my $RECONNECT_TIME = 60;
 my $SOCK_TIMEOUT = 10;
 my $PING_TIMEOUT = 120;
 my $PONG_TIMEOUT = 60;
 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_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';
 
 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 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 = $min + int rand(1 + $max - $min);
 		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}"
 		} else {
 			$reply = "Thanks, ${sender_nick}! ${MATA_HAPPY}"
 		}
 	} 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 ($sender_nick eq $MOTHER) {
 		$reply = "Done, mother! ${MATA_HAPPY}"
 	} else {
 		$reply = "\1ACTION leans over and places it's hand near it's antenna. \"HUUH?\" ${MATA_NORM}\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} ?";
 	} else {
 		$reply = "$quotes->[rand @$quotes] ${MATA_NORM}";
 	}
 	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]*))?,) {
 		# 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;
 		if ($mods =~ /g/) {
 			$ismatch = $prev_message =~ s/$regex/$repl/g;
 		} else {
 			$ismatch = $prev_message =~ s/$regex/$repl/;
 		}
 		if ($ismatch) {
 			$reply = "${sender_nick} meant to say: ${prev_message}"
 		}
 		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=${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 $response->{content}) {
 			$reply = "failed to get title of youtube video ${video_id} ${MATA_DEAD} (HTTP response empty!)";
 			return $message, $reply;
 		}
 		my $content = $response->{content};
 		if ($content =~ 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}!)";
 		}
 	} 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 ($response->{headers}->{'content-type'}) {
 			$reply = "no content-type header in HTTP response (HEAD ${url}) ${MATA_DEAD}";
 			return $message, $reply;
 		}
 		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;
 		}
 
 		# 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 (length $response->{content}) {
 			$reply = "Empty HTTP response (GET ${url}) ${MATA_DEAD}";
 			return $message, $reply;
 		}
 		my $content = $response->{content};
 		if ($content =~ 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);
 	}
 	return $message, $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';
 	} else {
 		die "logger: invalid logging level '${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);
 	$! = 0;
 	if ($s->can_write($SOCK_TIMEOUT)) {
 		print $sock $message . "\r\n";
 		logger($opts, 'info', '<- ' . $message);
 		return 1;
 	} else {
 		if ($!) { logger($opts, 'error', $!); return; }
 		return 0;
 	}
 }
 
 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;
 
 	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');
 				return;
 			}
 			return if not $chunk;
 			$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);
 				$reply = "PRIVMSG $opts->{'chan'} :${reply}" if $reply;
 			}
 			out($sock, $opts, $reply) if $reply;
 		} else {
 			if ($!) { logger($opts, 'error', $!); return; }
 		}
 			
 		# ping-pong
 		if ($checkping and time-$pingtime >= $PING_TIMEOUT) {
 			# ping server every once in a while and wait for pong
 			out($sock, $opts, "PING $opts->{'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
 		}
 	}
 }
 
 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;
 
 	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';
 	}
 	$loglevel = 'info' if $flags{'v'};
 	open (my $ball_file, '<', $ball_path) or die "couldn't open ${ball_path}: $!";
 	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}: $!";
 
 	return {
 		chan => $chan,	
 		host => $host,
 		logging => $logging,
 		loglevel => $loglevel,
 		port => $port,
 		tls => $tls,
 	},
 	{
 		ball => \@ball,
 		hellos => \@hellos,
 		quotes => \@quotes,
 	};
 }
 
 my ($opts, $lists) = init();
 while (1) {
 	# start the connection
 	my $sock;
 	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: $IO::Socket::errstr");
 			$sock = undef;
 		}
 	} 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;
 		}
 	}
 	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();
 		}
 	}
 	logger($opts, 'error', "reconnecting in ${RECONNECT_TIME} seconds...");
 	sleep $RECONNECT_TIME;
 }