--- trunk/bin/irc-logger.pl 2007/12/16 18:51:05 71 +++ trunk/bin/irc-logger.pl 2008/04/01 19:04:32 132 @@ -2,6 +2,24 @@ use strict; $|++; +use POE qw(Component::IRC Component::Server::HTTP Component::Client::HTTP); +use HTTP::Status; +use DBI; +use Regexp::Common qw /URI/; +use CGI::Simple; +use HTML::TagCloud; +use POSIX qw/strftime/; +use HTML::CalendarMonthSimple; +use Getopt::Long; +use DateTime; +use URI::Escape; +use Data::Dump qw/dump/; +use DateTime::Format::ISO8601; +use Carp qw/confess/; +use XML::Feed; +use DateTime::Format::Flexible; +use Encode; + =head1 NAME irc-logger.pl @@ -20,8 +38,6 @@ =item --log=irc-logger.log -Name of log file - =back =head1 DESCRIPTION @@ -32,57 +48,57 @@ ## CONFIG -my $HOSTNAME = `hostname`; +my $debug = 0; + +my $irc_config = { + nick => 'irc-logger', + server => 'irc.freenode.net', + port => 6667, + ircname => 'Anna the bot: try /msg irc-logger help', +}; + +my $HOSTNAME = `hostname -f`; +chomp($HOSTNAME); + -my $NICK = 'irc-logger'; -$NICK .= '-dev' if ($HOSTNAME =~ m/llin/); -my $CONNECT = - {Server => 'irc.freenode.net', - Nick => $NICK, - Ircname => "try /msg $NICK help", - }; my $CHANNEL = '#razmjenavjestina'; -$CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/); -my $IRC_ALIAS = "log"; -my %FOLLOWS = - ( - ACCESS => "/var/log/apache/access.log", - ERROR => "/var/log/apache/error.log", - ); +if ( $HOSTNAME =~ m/llin/ ) { + $irc_config->{nick} = 'irc-logger-llin'; +# $irc_config = { +# nick => 'irc-logger-llin', +# server => 'localhost', +# port => 6668, +# }; + $CHANNEL = '#irc-logger'; +} elsif ( $HOSTNAME =~ m/lugarin/ ) { + $irc_config->{server} = 'irc.carnet.hr'; + $CHANNEL = '#riss'; +} + +my @channels = ( $CHANNEL ); + +warn "## config = ", dump( $irc_config ) if $debug; + +my $NICK = $irc_config->{nick} or die "no nick?"; my $DSN = 'DBI:Pg:dbname=' . $NICK; -my $ENCODING = 'ISO-8859-2'; my $TIMESTAMP = '%Y-%m-%d %H:%M:%S'; my $sleep_on_error = 5; -my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000; -my $http_hostname = `hostname`; -chomp( $http_hostname ); +# number of last tags to keep in circular buffer +my $last_x_tags = 50; -## END CONFIG +# don't pull rss feeds more often than this +my $rss_min_delay = 60; +my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000; +my $url = "http://$HOSTNAME:$http_port"; -use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP); -use HTTP::Status; -use DBI; -use Encode qw/from_to is_utf8/; -use Regexp::Common qw /URI/; -use CGI::Simple; -use HTML::TagCloud; -use POSIX qw/strftime/; -use HTML::CalendarMonthSimple; -use Getopt::Long; -use DateTime; -use URI::Escape; -use Data::Dump qw/dump/; -use DateTime::Format::ISO8601; -use Carp qw/confess/; -use XML::Feed; -use DateTime::Format::Flexible; +## END CONFIG my $use_twitter = 1; eval { require Net::Twitter; }; @@ -93,18 +109,20 @@ GetOptions( 'import-dircproxy:s' => \$import_dircproxy, 'log:s' => \$log_path, + 'debug!' => \$debug, ); -$SIG{__DIE__} = sub { - confess "fatal error"; -}; - -open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!"; +#$SIG{__DIE__} = sub { +# confess "fatal error"; +#}; sub _log { - print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/; + print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/; } +open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n"; + + # HTML formatters my %escape = ('<'=>'<', '>'=>'>', '&'=>'&', '"'=>'"'); @@ -122,13 +140,13 @@ # protect HTML from wiki modifications sub e { my $t = shift; - return 'uri_unescape{' . uri_escape($t) . '}'; + return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}'; } $m =~ s/($escape_re)/$escape{$1}/gs; - $m =~ s#($RE{URI}{HTTP})#e(qq{$1})#egs || + $m =~ s#($RE{URI}{HTTP})#e(qq{$1})#egs; $m =~ s#\/(\w+)\/#$1#gs; - $m =~ s#$tag_regex#e(qq{$1})#egs; + $m =~ s#$tag_regex#e(qq{$1})#egs; $m =~ s#\*(\w+)\*#$1#gs; $m =~ s#_(\w+)_#$1#gs; @@ -147,10 +165,18 @@ }, }; +# POE IRC +my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or + die "can't start ", dump( $irc_config ), ": $!"; + +my $irc = $poe_irc->session_id(); +_log "IRC session_id $irc"; + my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr; +$dbh->do( qq{ set client_encoding = 'UTF-8' } ); my $sql_schema = { - log => ' + log => qq{ create table log ( id serial, time timestamp default now(), @@ -164,17 +190,34 @@ create index log_time on log(time); create index log_channel on log(channel); create index log_nick on log(nick); - ', - meta => ' + }, + meta => q{ create table meta ( nick text not null, channel text not null, name text not null, value text, - changed timestamp default now(), + changed timestamp default 'now()', primary key(nick,channel,name) ); - ', + }, + feeds => qq{ +create table feeds ( + id serial, + url text not null, + name text, + delay interval not null default '5 min', + active boolean default true, + channel text not null, + nick text not null, + private boolean default false, + last_update timestamp default 'now()', + polls int default 0, + updates int default 0 +); +create unique index feeds_url on feeds(url); +insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin'); + }, }; foreach my $table ( keys %$sql_schema ) { @@ -217,9 +260,9 @@ if ( $@ || ! $sth->rows ) { $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) }); $sth->execute( $value, $nick, $channel, $name ); - _log "created $nick/$channel/$name = $value"; + warn "## created $nick/$channel/$name = $value\n"; } else { - _log "updated $nick/$channel/$name = $value "; + warn "## updated $nick/$channel/$name = $value\n"; } return $value; @@ -229,7 +272,7 @@ my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? }); $sth->execute( $nick, $channel, $name ); my ($v,$c) = $sth->fetchrow_array; - _log "fetched $nick/$channel/$name = $v [$c]"; + warn "## fetched $nick/$channel/$name = $v [$c]\n"; return ($v,$c) if wantarray; return $v; @@ -238,7 +281,7 @@ -my $sth = $dbh->prepare(qq{ +my $sth_insert_log = $dbh->prepare(qq{ insert into log (channel, me, nick, message, time) values (?,?,?,?,?) @@ -326,25 +369,26 @@ my @where; my @args; + my $msg; if (my $search = $args->{search}) { $search =~ s/^\s+//; $search =~ s/\s+$//; push @where, 'message ilike ? or nick ilike ?'; push @args, ( ( '%' . $search . '%' ) x 2 ); - _log "search for '$search'"; + $msg = "Search for '$search'"; } if ($args->{tag} && $tags->{ $args->{tag} }) { push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')'; - _log "search for tags $args->{tag}"; + $msg = "Search for tags $args->{tag}"; } if (my $date = $args->{date} ) { $date = check_date( $date ); push @where, 'date(time) = ?'; push @args, $date; - _log "search for date $date"; + $msg = "search for date $date"; } $sql .= " where " . join(" and ", @where) if @where; @@ -358,6 +402,8 @@ eval { $sth->execute( @args ) }; return if $@; + my $nr_results = $sth->rows; + my $last_row = { date => '', time => '', @@ -378,10 +424,14 @@ return @rows if ($args->{full_rows}); - my @msgs = ( - "Showing " . ($#rows + 1) . " messages..." + $msg .= ' produced ' . ( + $nr_results == 0 ? 'no results' : + $nr_results == 0 ? 'one result' : + $nr_results . ' results' ); + my @msgs = ( $msg ); + if ($context) { my @ids = @rows; @rows = (); @@ -438,6 +488,8 @@ # $row->{nick} = $nick; # } + $append = 0 if $row->{me}; + if ($last_row->{nick} ne $nick) { # obfu way to find format for me_nick if needed or fallback to default my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick}; @@ -482,7 +534,6 @@ =cut -my $last_x_tags = 5; my @last_tags; sub add_tag { @@ -491,7 +542,6 @@ return unless ($arg->{id} && $arg->{message}); my $m = $arg->{message}; - from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m)); my @tags; @@ -500,14 +550,14 @@ next if (! $tag || $tag =~ m/https?:/i); push @{ $tags->{$tag} }, $arg->{id}; #warn "+tag $tag: $arg->{id}\n"; - $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1); + $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1); push @tags, $tag; } if ( @tags ) { - shift @last_tags if $#last_tags == $last_x_tags; - push @last_tags, { tags => [ @tags ], %$arg }; + pop @last_tags if $#last_tags == $last_x_tags; + unshift @last_tags, { tags => [ @tags ], %$arg }; } } @@ -519,14 +569,14 @@ =cut sub seed_tags { - my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' }); + my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc }); $sth->execute; while (my $row = $sth->fetchrow_hashref) { add_tag( %$row ); } foreach my $tag (keys %$tags) { - $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1); + $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1); } } @@ -555,14 +605,13 @@ $a->{me} ||= 0; $a->{time} ||= strftime($TIMESTAMP,localtime()); - _log + _log "ARCHIVE", $a->{channel}, " ", $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">", " " . $a->{message}; - from_to($a->{message}, 'UTF-8', $ENCODING); - - $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time}); + eval { $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time}); }; + _log "ERROR: can't archive ", $a->{message} if $@; add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a ); } @@ -601,29 +650,367 @@ exit; } - # -# POE handing part +# RSS follow # -my $SKIPPING = 0; # if skipping, how many we've done -my $SEND_QUEUE; # cache -my $ping; # ping stats - -POE::Component::IRC->new($IRC_ALIAS); - -POE::Session->create( inline_states => - {_start => sub { - $_[KERNEL]->post($IRC_ALIAS => register => 'all'); - $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT); - }, - irc_255 => sub { # server is done blabbing - $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL); - $_[KERNEL]->post($IRC_ALIAS => join => '#logger'); - $_[KERNEL]->yield("heartbeat"); # start heartbeat -# $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS; - $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" ); +my $_stat; + +POE::Component::Client::HTTP->spawn( + Alias => 'rss-fetch', + Timeout => 30, +); + +=head2 rss_parse_xml + + rss_parse_xml({ + url => 'http://www.example.com/rss', + send_rss_msgs => 42, + }); + +=cut + +sub rss_parse_xml { + my ($kernel,$args) = @_; + + warn "## rss_parse_xml ",dump( $args ) if $debug; + + # how many messages to send out when feed is seen for the first time? + my $send_rss_msgs = $args->{send_rss_msgs}; + $send_rss_msgs = 1 if ! defined $send_rss_msgs; + + warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug; + + my $feed = XML::Feed->parse( \$args->{xml} ); + if ( ! $feed ) { + _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr; + return; + } + + $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link; + + my ( $total, $updates ) = ( 0, 0 ); + for my $entry ($feed->entries) { + $total++; + + my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++; + # seen allready? + warn "## $seen_times ",$entry->id if $debug; + next if $seen_times > 0; + + sub prefix { + my ($txt,$var) = @_; + $var =~ s/\s+/ /gs; + $var =~ s/^\s+//g; + $var =~ s/\s+$//g; + return $txt . $var if $var; + } + + # fix absolute and relative links to feed entries + my $link = $entry->link; + if ( $link =~ m!^/! ) { + my $host = $args->{url}; + $host =~ s!^(http://[^/]+).*$!$1!; #!vim + $link = "$host/$link"; + } elsif ( $link !~ m!^http! ) { + $link = $args->{url} . $link; + } + + my $msg; + $msg .= prefix( 'From: ' , $args->{name} || $feed->title ); + $msg .= prefix( ' by ' , $entry->author ); + $msg .= prefix( ' | ' , $entry->title ); + $msg .= prefix( ' | ' , $link ); +# $msg .= prefix( ' id ' , $entry->id ); + my @categories = $entry->category; + warn "## category = ", dump( @categories ) if $debug; + if ( my $tags = $entry->category ) { + $tags = join(' ', @$tags) if ref($tags) eq 'ARRAY'; + $tags =~ s!^\s+!!; + $tags =~ s!\s*$! !; + $tags =~ s!,?\s+!// !g; + $msg .= prefix( ' ' , $tags ); + } + + if ( $seen_times == 0 && $send_rss_msgs ) { + $send_rss_msgs--; + if ( ! $args->{private} ) { + # FIXME bug! should be save_message + save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg ); +# $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' ); + } + my ( $type, $to ) = ( 'notice', $args->{channel} ); + ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private}; + + _log(">> RSS $type to $to:", $msg); + $kernel->post( $irc => $type => $to => $msg ); + + $updates++; + } + } + + my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 }; + $sql .= qq{, updates = updates + $updates } if $updates; + $sql .= qq{where id = } . $args->{id}; + eval { $dbh->do( $sql ) }; + + _log "RSS $updates/$total new items from", $args->{url}; + + return $updates; +} + +sub rss_fetch_all { + my ( $kernel, $send_rss_msgs ) = @_; + warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug; + my $sql = qq{ + select id, url, name, channel, nick, private + from feeds + where active is true + }; + # limit to newer feeds only if we are not sending messages out + $sql .= qq{ and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} ); + my $sth = $dbh->prepare( $sql ); + $sth->execute(); + warn "# ",$sth->rows," active RSS feeds\n"; + my $count = 0; + while (my $row = $sth->fetchrow_hashref) { + $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs; + $_stat->{rss}->{fetch}->{ $row->{url} } = $row; + $kernel->post( + 'rss-fetch', + 'request', + 'rss_response', + HTTP::Request->new( GET => $row->{url} ), + ); + warn "## queued rss-fetch ", dump( $row ) if $debug; + } + return "OK, scheduled " . $sth->rows . " feeds for refresh"; +} + + +sub rss_check_updates { + my $kernel = shift; + $_stat->{rss}->{last_poll} ||= time(); + my $dt = time() - $_stat->{rss}->{last_poll}; + if ( $dt > $rss_min_delay ) { + warn "## rss_check_updates $dt > $rss_min_delay\n"; + $_stat->{rss}->{last_poll} = time(); + _log rss_fetch_all( $kernel ); + } +} + +sub process_command { + my ( $kernel, $nick, $channel, $msg ) = @_; + + my $res = "unknown command '$msg', try /msg $NICK help!"; + + if ($msg =~ m/^help/i) { + + $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar"; + + } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) { + + _log ">> /$1 $2 $3"; + $kernel->post( $irc => $1 => $2, $3 ); + $res = ''; + + } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) { + + my $nr = $1 || 10; + + my $sth = $dbh->prepare(qq{ + select + trim(both '_' from nick) as nick, + count(*) as count, + sum(length(message)) as len + from log + group by trim(both '_' from nick) + order by len desc,count desc + limit $nr + }); + $sth->execute(); + $res = "Top $nr users: "; + my @users; + while (my $row = $sth->fetchrow_hashref) { + push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count}); + } + $res .= join(" | ", @users); + } elsif ($msg =~ m/^last.*?\s*(\d*)/i) { + + my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10; + + foreach my $res (get_from_log( limit => $limit )) { + _log "last: $res"; + $kernel->post( $irc => privmsg => $nick, $res ); + } + + $res = ''; + + } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) { + + my $what = $2; + + foreach my $res (get_from_log( + limit => 20, + search => $what, + )) { + _log "search [$what]: $res"; + $kernel->post( $irc => privmsg => $nick, $res ); + } + + $res = ''; + + } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) { + + my ($what,$limit) = ($1,$2); + $limit ||= 100; + + my $stat; + + foreach my $res (get_from_log( + limit => $limit, + search => $what, + full_rows => 1, + )) { + while ($res->{message} =~ s/\Q$what\E(\+|\-)//) { + $stat->{vote}->{$1}++; + $stat->{from}->{ $res->{nick} }++; + } + } + + my @nicks; + foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) { + push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' : + "(" . $stat->{from}->{$nick} . ")" + ); + } + + $res = + "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) . + " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" . + " from " . ( join(", ", @nicks) || 'nobody' ); + + $kernel->post( $irc => notice => $nick, $res ); + + } elsif ($msg =~ m/^ping/) { + $res = "ping = " . dump( $_stat->{ping} ); + } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) { + if ( ! defined( $1 ) ) { + my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? }); + $sth->execute( $nick, $channel ); + $res = "config for $nick on $channel"; + while ( my ($n,$v) = $sth->fetchrow_array ) { + $res .= " | $n = $v"; + } + } elsif ( ! $2 ) { + my $val = meta( $nick, $channel, $1 ); + $res = "current $1 = " . ( $val ? $val : 'undefined' ); + } else { + my $validate = { + 'last-size' => qr/^\d+/, + 'twitter' => qr/^\w+\s+\w+/, + }; + + my ( $op, $val ) = ( $1, $2 ); + + if ( my $regex = $validate->{$op} ) { + if ( $val =~ $regex ) { + meta( $nick, $channel, $op, $val ); + $res = "saved $op = $val"; + } else { + $res = "config option $op = $val doesn't validate against $regex"; + } + } else { + $res = "config option $op doesn't exist"; + } + } + } elsif ($msg =~ m/^rss-update/) { + $res = rss_fetch_all( $kernel ); + } elsif ($msg =~ m/^rss-list/) { + my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds }); + $sth->execute; + while (my @row = $sth->fetchrow_array) { + $kernel->post( $irc => privmsg => $nick, join(' | ',@row) ); + } + $res = ''; + } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) { + my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 ); + + my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// ); + $channel = $nick if $sub eq 'private'; + + my $sql = { + add => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) }, + remove => qq{ delete from feeds where url = ? and nick = ? }, + start => qq{ update feeds set active = true where url = ? }, + stop => qq{ update feeds set active = false where url = ? }, + clean => qq{ update feeds set last_update = now() - delay where url = ? }, + }; + + if ( $command eq 'add' && ! $channel ) { + $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!"; + } elsif (my $q = $sql->{$command} ) { + my $sth = $dbh->prepare( $q ); + my @data = ( $url ); + if ( $command eq 'add' ) { + push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 ); + } elsif ( $command eq 'remove' ) { + push @data, $nick; + } + warn "## $command SQL $q with ",dump( @data ),"\n"; + eval { $sth->execute( @data ) }; + if ($@) { + $res = "ERROR: $@"; + } else { + $res = "OK, RSS executed $command" . + ( $sub ? "-$sub " : ' ' ) . + ( $channel ? "on $channel " : '' ) . + "url $url"; + if ( $command eq 'clean' ) { + my $seen = $_stat->{rss}->{seen} || die "no seen?"; + my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)"; + foreach my $c ( keys %$seen ) { + my $c_hash = $seen->{$c} || die "no seen->{$c}"; + die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH'; + foreach my $link ( keys %$c_hash ) { + next unless $link eq $want_link; + _log "RSS removed seen $c $url $link"; + } + } + } elsif ( $command eq 'add' ) { + rss_fetch_all( $kernel ); + } + } + } else { + $res = "ERROR: don't know what to do with: $msg"; + } + } elsif ($msg =~ m/^rss-clean/) { + # this makes sense because we didn't catch rss-clean http://... before! + $_stat->{rss} = undef; + $dbh->do( qq{ update feeds set last_update = now() - delay } ); + $res = rss_fetch_all( $kernel ); + } + + return $res; +} + +POE::Session->create( inline_states => { + _start => sub { + $_[KERNEL]->post( $irc => register => 'all' ); + $_[KERNEL]->post( $irc => connect => {} ); }, + irc_001 => sub { + my ($kernel,$sender) = @_[KERNEL,SENDER]; + my $poco_object = $sender->get_heap(); + _log "connected to",$poco_object->server_name(); + $kernel->post( $sender => join => $_ ) for @channels; + # seen RSS cache, so don't send out messages + _log rss_fetch_all( $kernel, 0 ); + undef; + }, +# irc_255 => sub { # server is done blabbing +# $_[KERNEL]->post( $irc => join => $CHANNEL); +# }, irc_public => sub { my $kernel = $_[KERNEL]; my $nick = (split /!/, $_[ARG0])[0]; @@ -632,6 +1019,7 @@ save_message( channel => $channel, me => 0, nick => $nick, message => $msg); meta( $nick, $channel, 'last-msg', $msg ); + rss_check_updates( $kernel ); }, irc_ctcp_action => sub { my $kernel = $_[KERNEL]; @@ -652,267 +1040,132 @@ }, irc_ping => sub { - warn "pong ", $_[ARG0], $/; - $ping->{ $_[ARG0] }++; + _log( "pong ", $_[ARG0] ); + $_stat->{ping}->{ $_[ARG0] }++; + rss_check_updates( $_[KERNEL] ); }, irc_invite => sub { my $kernel = $_[KERNEL]; my $nick = (split /!/, $_[ARG0])[0]; my $channel = $_[ARG1]; - warn "invited to $channel by $nick"; + _log "invited to $channel by $nick"; - $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." ); - $_[KERNEL]->post($IRC_ALIAS => join => $channel); + $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." ); + $_[KERNEL]->post( $irc => 'join' => $channel ); }, irc_msg => sub { my $kernel = $_[KERNEL]; my $nick = (split /!/, $_[ARG0])[0]; - my $msg = $_[ARG2]; my $channel = $_[ARG1]->[0]; - from_to($msg, 'UTF-8', $ENCODING); - - my $res = "unknown command '$msg', try /msg $NICK help!"; - my @out; + my $msg = $_[ARG2]; + warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug; _log "<< $msg"; - if ($msg =~ m/^help/i) { - - $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar"; - - } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) { - - _log ">> /msg $1 $2"; - $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 ); - $res = ''; - - } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) { - - my $nr = $1 || 10; - - my $sth = $dbh->prepare(qq{ - select - trim(both '_' from nick) as nick, - count(*) as count, - sum(length(message)) as len - from log - group by trim(both '_' from nick) - order by len desc,count desc - limit $nr - }); - $sth->execute(); - $res = "Top $nr users: "; - my @users; - while (my $row = $sth->fetchrow_hashref) { - push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count}); - } - $res .= join(" | ", @users); - } elsif ($msg =~ m/^last.*?\s*(\d*)/i) { - - my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10; - - foreach my $res (get_from_log( limit => $limit )) { - _log "last: $res"; - from_to($res, $ENCODING, 'UTF-8'); - $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res ); - } - - $res = ''; - - } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) { - - my $what = $2; - - foreach my $res (get_from_log( - limit => 20, - search => $what, - )) { - _log "search [$what]: $res"; - from_to($res, $ENCODING, 'UTF-8'); - $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res ); - } - - $res = ''; - - } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) { - - my ($what,$limit) = ($1,$2); - $limit ||= 100; - - my $stat; - - foreach my $res (get_from_log( - limit => $limit, - search => $what, - full_rows => 1, - )) { - while ($res->{message} =~ s/\Q$what\E(\+|\-)//) { - $stat->{vote}->{$1}++; - $stat->{from}->{ $res->{nick} }++; - } - } - - my @nicks; - foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) { - push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' : - "(" . $stat->{from}->{$nick} . ")" - ); - } - - $res = - "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) . - " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" . - " from " . ( join(", ", @nicks) || 'nobody' ); - - $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res ); - - } elsif ($msg =~ m/^ping/) { - $res = "ping = " . dump( $ping ); - } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) { - if ( ! defined( $1 ) ) { - my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? }); - $sth->execute( $nick, $channel ); - $res = "config for $nick on $channel"; - while ( my ($n,$v) = $sth->fetchrow_array ) { - $res .= " | $n = $v"; - } - } elsif ( ! $2 ) { - my $val = meta( $nick, $channel, $1 ); - $res = "current $1 = " . ( $val ? $val : 'undefined' ); - } else { - my $validate = { - 'last-size' => qr/^\d+/, - 'twitter' => qr/^\w+\s+\w+/, - }; - - my ( $op, $val ) = ( $1, $2 ); - - if ( my $regex = $validate->{$op} ) { - if ( $val =~ $regex ) { - meta( $nick, $channel, $op, $val ); - $res = "saved $op = $val"; - } else { - $res = "config option $op = $val doesn't validate against $regex"; - } - } else { - $res = "config option $op doesn't exist"; - } - } - } + my $res = process_command( $_[KERNEL], $nick, $channel, $msg ); if ($res) { _log ">> [$nick] $res"; - from_to($res, $ENCODING, 'UTF-8'); - $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res ); + $_[KERNEL]->post( $irc => privmsg => $nick, $res ); } + rss_check_updates( $_[KERNEL] ); }, + irc_372 => sub { + _log "<< motd",$_[ARG0],$_[ARG1]; + }, + irc_375 => sub { + _log "<< motd", $_[ARG0], "start"; + }, + irc_376 => sub { + _log "<< motd", $_[ARG0], "end"; + }, +# irc_433 => sub { +# print "# irc_433: ",$_[ARG1], "\n"; +# warn "## indetify $NICK\n"; +# $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" ); +# }, +# irc_451 # please register irc_477 => sub { - _log "# irc_477: ",$_[ARG1]; - $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" ); + _log "<< irc_477: ",$_[ARG1]; + _log ">> IDENTIFY $NICK"; + $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" ); }, irc_505 => sub { - _log "# irc_505: ",$_[ARG1]; - $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" ); -# $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" ); -# $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" ); + _log "<< irc_505: ",$_[ARG1]; + _log ">> register $NICK"; + $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" ); +# $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" ); +# $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" ); +# $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" ); }, irc_registered => sub { - _log "## registrated $NICK"; - $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" ); + _log "<< registered $NICK"; }, irc_disconnected => sub { - _log "## disconnected, reconnecting again"; - $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT); + _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again"; + sleep($sleep_on_error); + $_[KERNEL]->post( $irc => connect => {} ); }, irc_socketerr => sub { _log "## socket error... sleeping for $sleep_on_error seconds and retry"; sleep($sleep_on_error); - $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT); + $_[KERNEL]->post( $irc => connect => {} ); + }, + irc_notice => sub { + _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2]; + my $m = $_[ARG2]; + if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) { + _log ">> suggested to $1 $2"; + $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" ); + } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) { + _log ">> registreted, so IDENTIFY"; + $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" ); + } else { + warn "## ignore $m\n" if $debug; + } + }, + irc_snotice => sub { + _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] ); + if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) { + warn ">> $1 | $2\n"; + $_[KERNEL]->post( $irc => lc($1) => $2); + } }, -# irc_433 => sub { -# print "# irc_433: ",$_[ARG1], "\n"; -# warn "## indetify $NICK\n"; -# $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" ); -# }, _child => sub {}, _default => sub { - _log sprintf "sID:%s %s %s", - $_[SESSION]->ID, $_[ARG0], - ref($_[ARG1]) eq "ARRAY" ? join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] }) : - $_[ARG1] ? $_[ARG1] : - ""; - 0; # false for signals - }, - my_add => sub { - my $trailing = $_[ARG0]; - my $session = $_[SESSION]; - POE::Session->create - (inline_states => - {_start => sub { - $_[HEAP]->{wheel} = - POE::Wheel::FollowTail->new - ( - Filename => $FOLLOWS{$trailing}, - InputEvent => 'got_line', - ); - }, - got_line => sub { - $_[KERNEL]->post($session => my_tailed => - time, $trailing, $_[ARG0]); - }, - }, - ); - - }, - my_tailed => sub { - my ($time, $file, $line) = @_[ARG0..ARG2]; - ## $time will be undef on a probe, or a time value if a real line - - ## PoCo::IRC has throttling built in, but no external visibility - ## so this is reaching "under the hood" - $SEND_QUEUE ||= - $_[KERNEL]->alias_resolve($IRC_ALIAS)->get_heap->{send_queue}; - - ## handle "no need to keep skipping" transition - if ($SKIPPING and @$SEND_QUEUE < 1) { - $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL => - "[discarded $SKIPPING messages]"); - $SKIPPING = 0; - } - - ## handle potential message display - if ($time) { - if ($SKIPPING or @$SEND_QUEUE > 3) { # 3 msgs per 10 seconds - $SKIPPING++; - } else { - my @time = localtime $time; - $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL => - sprintf "%02d:%02d:%02d: %s: %s", - ($time[2] + 11) % 12 + 1, $time[1], $time[0], - $file, $line); - } - } - - ## handle re-probe/flush if skipping - if ($SKIPPING) { - $_[KERNEL]->delay($_[STATE] => 0.5); # $time will be undef - } - + _log '_default SID:', $_[SESSION]->ID, $_[ARG0], dump( $_[ARG1] ); + 0; # false for signals }, - my_heartbeat => sub { - $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep"); - $_[KERNEL]->delay($_[STATE] => 10); - } + rss_response => sub { + my ($request_packet, $response_packet) = @_[ARG0, ARG1]; + my $request_object = $request_packet->[0]; + my $response_object = $response_packet->[0]; + + my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } ); + if ( $row ) { + $row->{xml} = $response_object->content; + rss_parse_xml( $_[KERNEL], $row ); + } else { + warn "## can't find rss->fetch for ", $request_object->uri; + } + }, }, ); # http server +_log "WEB archive at $url"; + my $httpd = POE::Component::Server::HTTP->new( Port => $http_port, + PreHandler => { + '/' => sub { + $_[0]->header(Connection => 'close') + } + }, ContentHandler => { '/' => \&root_handler }, Headers => { Server => 'irc-logger' }, ); @@ -952,12 +1205,17 @@ $style .= ".col-${max_color} { background: $c }\n"; $max_color++; } -warn "defined $max_color colors for users...\n"; +_log "WEB defined $max_color colors for users..."; sub root_handler { my ($request, $response) = @_; $response->code(RC_OK); + # this doesn't seem to work, so moved to PreHandler + #$response->header(Connection => 'close'); + + return RC_OK if $request->uri =~ m/favicon.ico$/; + my $q; if ( $request->method eq 'POST' ) { @@ -969,64 +1227,143 @@ } my $search = $q->param('search') || $q->param('grep') || ''; + my $r_url = $request->url; + + my @commands = qw( tags last-tag follow stat ); + my $commands_re = join('|',@commands); + + if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) { + my $show = lc($1); + my $nr = $2; - if ($request->url =~ m#/rss#i) { my $type = 'RSS'; # Atom - my $url = "http://$http_hostname:$http_port"; - $response->content_type("application/$type+xml"); + $response->content_type( 'application/' . lc($type) . '+xml' ); my $html = ''; - warn "create $type feed from ",dump( @last_tags ); + #warn "create $type feed from ",dump( @last_tags ); my $feed = XML::Feed->new( $type ); + $feed->link( $url ); - $feed->title( "last $last_x_tags from $CHANNEL" ); - $feed->link( "http://$http_hostname:$http_port" ); - $feed->description( "collects messages which have tags// in them" ); - - foreach my $m ( @last_tags ) { - warn dump( $m ); - #my $tags = join(' ', @{$m->{tags}} ); + my $rc = RC_OK; + + if ( $show eq 'tags' ) { + $nr ||= 50; + $feed->title( "tags from $CHANNEL" ); + $feed->link( "$url/tags" ); + $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" ); my $feed_entry = XML::Feed::Entry->new($type); - $feed_entry->title( $m->{nick} . '@' . $m->{time} ); - $feed_entry->author( $m->{nick} ); -# $feed_entry->link( ); - $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) ); - $feed_entry->summary( - '{nick}->( $m->{nick} ) . -# '' . $m->{nick} . ' ' . - $filter->{message}->( $m->{message} ) . - ']]>' + $feed_entry->title( "$nr tags from $CHANNEL" ); + $feed_entry->author( $NICK ); + $feed_entry->link( '/#tags' ); + + $feed_entry->content( + qq{} + . $cloud->css + . qq{} + . $cloud->html( $nr ) + . qq{]]>} ); - $feed_entry->category( join(', ', @{$m->{tags}}) ); $feed->add_entry( $feed_entry ); + + } elsif ( $show eq 'last-tag' ) { + + $nr ||= $last_x_tags; + $nr = $last_x_tags if $nr > $last_x_tags; + + $feed->title( "last $nr tagged messages from $CHANNEL" ); + $feed->description( "collects messages which have tags// in them" ); + + foreach my $m ( @last_tags ) { +# warn dump( $m ); + #my $tags = join(' ', @{$m->{tags}} ); + my $feed_entry = XML::Feed::Entry->new($type); + $feed_entry->title( $m->{nick} . '@' . $m->{time} ); + $feed_entry->author( $m->{nick} ); + $feed_entry->link( '/#' . $m->{id} ); + $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) ); + + my $message = $filter->{message}->( $m->{message} ); + $message .= "
\n" unless $message =~ m!<(/p|br/?)>!; +# warn "## message = $message\n"; + + #$feed_entry->summary( + $feed_entry->content( + "" + ); + $feed_entry->category( join(', ', @{$m->{tags}}) ); + $feed->add_entry( $feed_entry ); + + $nr--; + last if $nr <= 0; + + } + + } elsif ( $show =~ m/^follow/ ) { + + $feed->title( "Feeds which this bot follows" ); + + my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } ); + $sth->execute; + while (my $row = $sth->fetchrow_hashref) { + my $feed_entry = XML::Feed::Entry->new($type); + $feed_entry->title( $row->{name} ); + $feed_entry->link( $row->{url} ); + $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) ); + $feed_entry->content( + '' . dump( $row ) . ']]>' + ); + $feed->add_entry( $feed_entry ); + } + + } elsif ( $show =~ m/^stat/ ) { + + my $feed_entry = XML::Feed::Entry->new($type); + $feed_entry->title( "Internal stats" ); + $feed_entry->content( + '' . dump( $_stat ) . ']]>' + ); + $feed->add_entry( $feed_entry ); + + } else { + _log "WEB unknown rss request $r_url"; + $feed->title( "unknown $r_url" ); + foreach my $c ( @commands ) { + my $feed_entry = XML::Feed::Entry->new($type); + $feed_entry->title( "rss/$c" ); + $feed_entry->link( "$url/rss/$c" ); + $feed->add_entry( $feed_entry ); + } + $rc = RC_DENY; } $response->content( $feed->as_xml ); - return RC_OK; + return $rc; } if ( $@ ) { warn "$@"; } - $response->content_type("text/html; charset=$ENCODING"); + $response->content_type("text/html; charset=UTF-8"); my $html = - qq{$NICK} . - qq{ + qq{$NICK} + . qq{ - } . - $cloud->html(500) . - qq{

}; - if ($request->url =~ m#/history#) { + } + . $cloud->html(500) + . qq{

}; + + if ($request->url =~ m#/tags?#) { + # nop + } elsif ($request->url =~ m#/history#) { my $sth = $dbh->prepare(qq{ select date(time) as date,count(*) as nr,sum(length(message)) as len from log @@ -1058,9 +1395,9 @@ $cal->weekdays('MON','TUE','WED','THU','FRI'); ($l_yyyy,$l_mm) = ($yyyy,$mm); } - $cal->setcontent($dd, qq{ - $row->{nr}
$row->{len} - }); + $cal->setcontent($dd, qq[ + $row->{nr}
$row->{len} + ]) if $cal; } $html .= qq{} . $cal->as_HTML() . qq{}; @@ -1075,7 +1412,7 @@ fmt => { date => sub { my $date = shift || return; - qq{


$date
}; + qq{
$date
}; }, time => '%s ', time_channel => '%s %s ', @@ -1093,7 +1430,8 @@

See history of all messages.

}; - $response->content( $html ); + $response->content( decode('utf-8',$html) ); + warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n"; return RC_OK; }