--- trunk/bin/irc-logger.pl 2007/03/18 17:00:16 53 +++ trunk/bin/irc-logger.pl 2008/03/14 13:37:45 120 @@ -2,6 +2,25 @@ use strict; $|++; +use POE qw(Component::IRC Component::Server::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 IPC::DirQueue; +use File::Slurp; + =head1 NAME irc-logger.pl @@ -20,8 +39,6 @@ =item --log=irc-logger.log -Name of log file - =back =head1 DESCRIPTION @@ -32,67 +49,145 @@ ## 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 $queue_dir = './queue'; + +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 ), $/; + +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; -## END CONFIG +# number of last tags to keep in circular buffer +my $last_x_tags = 50; +# don't pull rss feeds more often than this +my $rss_min_delay = 60; +my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000; -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 Data::Dump qw/dump/; -use Net::Twitter; +my $url = "http://$HOSTNAME:$http_port"; + +## END CONFIG + +my $use_twitter = 1; +eval { require Net::Twitter; }; +$use_twitter = 0 if ($@); my $import_dircproxy; my $log_path; GetOptions( 'import-dircproxy:s' => \$import_dircproxy, 'log:s' => \$log_path, + 'queue:s' => \$queue_dir, ); -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"; + +# queue + +if ( ! -d $queue_dir ) { + warn "## creating queue directory $queue_dir"; + mkdir $queue_dir or die "can't create queue directory $queue_dir: $!"; +} + +my $dq = IPC::DirQueue->new({ dir => $queue_dir }); + +# HTML formatters + +my %escape = ('<'=>'<', '>'=>'>', '&'=>'&', '"'=>'"'); +my $escape_re = join '|' => keys %escape; + +my $tag_regex = '\b([\w-_]+)//'; + +my %nick_enumerator; +my $max_color = 0; + +my $filter = { + message => sub { + my $m = shift || return; + + # protect HTML from wiki modifications + sub e { + my $t = shift; + 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#\/(\w+)\/#$1#gs; + $m =~ s#$tag_regex#e(qq{$1})#egs; + $m =~ s#\*(\w+)\*#$1#gs; + $m =~ s#_(\w+)_#$1#gs; + + $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs; + return $m; + }, + nick => sub { + my $n = shift || return; + if (! $nick_enumerator{$n}) { + my $max = scalar keys %nick_enumerator; + $nick_enumerator{$n} = $max + 1; + } + return '' . $n . ''; + }, +}; + +# 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(), @@ -106,17 +201,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 ) { @@ -159,9 +271,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; @@ -171,7 +283,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; @@ -180,7 +292,7 @@ -my $sth = $dbh->prepare(qq{ +my $sth_insert_log = $dbh->prepare(qq{ insert into log (channel, me, nick, message, time) values (?,?,?,?,?) @@ -188,7 +300,6 @@ my $tags; -my $tag_regex = '\b([\w-_]+)//'; =head2 get_from_log @@ -225,14 +336,16 @@ sub get_from_log { my $args = {@_}; - $args->{fmt} ||= { - date => '[%s] ', - time => '{%s} ', - time_channel => '{%s %s} ', - nick => '%s: ', - me_nick => '***%s ', - message => '%s', - }; + if ( ! $args->{fmt} ) { + $args->{fmt} = { + date => '[%s] ', + time => '{%s} ', + time_channel => '{%s %s} ', + nick => '%s: ', + me_nick => '***%s ', + message => '%s', + }; + } my $sql_message = qq{ select @@ -255,27 +368,53 @@ my $sql = $context ? $sql_context : $sql_message; - $sql .= " where message ilike ? or nick ilike ? " if ($args->{search}); - $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} }); - $sql .= " where date(time) = ? " if ($args->{date}); - $sql .= " order by log.time desc"; - $sql .= " limit " . $args->{limit} if ($args->{limit}); + sub check_date { + my $date = shift || return; + my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; }; + if ( $@ ) { + warn "invalid date $date\n"; + $new_date = DateTime->now->ymd; + } + return $new_date; + } + + my @where; + my @args; + my $msg; - my $sth = $dbh->prepare( $sql ); if (my $search = $args->{search}) { $search =~ s/^\s+//; $search =~ s/\s+$//; - $sth->execute( ( '%' . $search . '%' ) x 2 ); - _log "search for '$search' returned ", $sth->rows, " results ", $context || ''; - } elsif (my $tag = $args->{tag}) { - $sth->execute(); - _log "tag '$tag' returned ", $sth->rows, " results ", $context || ''; - } elsif (my $date = $args->{date}) { - $sth->execute($date); - _log "found ", $sth->rows, " messages for date $date ", $context || ''; - } else { - $sth->execute(); + push @where, 'message ilike ? or nick ilike ?'; + push @args, ( ( '%' . $search . '%' ) x 2 ); + $msg = "Search for '$search'"; + } + + if ($args->{tag} && $tags->{ $args->{tag} }) { + push @where, 'id in (' . join(',', @{ $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; + $msg = "search for date $date"; } + + $sql .= " where " . join(" and ", @where) if @where; + + $sql .= " order by log.time desc"; + $sql .= " limit " . $args->{limit} if ($args->{limit}); + + #warn "### sql: $sql ", dump( @args ); + + my $sth = $dbh->prepare( $sql ); + eval { $sth->execute( @args ) }; + return if $@; + + my $nr_results = $sth->rows; + my $last_row = { date => '', time => '', @@ -296,10 +435,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 = (); @@ -356,6 +499,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}; @@ -396,25 +541,36 @@ =head2 add_tag - add_tag( id => 42, message => 'irc message' ); + add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] ); =cut +my @last_tags; + sub add_tag { my $arg = {@_}; return unless ($arg->{id} && $arg->{message}); my $m = $arg->{message}; - from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m)); + + my @tags; while ($m =~ s#$tag_regex##s) { my $tag = $1; 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 ) { + pop @last_tags if $#last_tags == $last_x_tags; + unshift @last_tags, { tags => [ @tags ], %$arg }; + } + } =head2 seed_tags @@ -424,14 +580,14 @@ =cut sub seed_tags { - my $sth = $dbh->prepare(qq{ select id,message 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); } } @@ -444,7 +600,7 @@ channel => '#foobar', me => 0, nick => 'dpavlin', - msg => 'test message', + message => 'test message', time => '2006-06-25 18:57:18', ); @@ -456,26 +612,24 @@ sub save_message { my $a = {@_}; + confess "have msg" if $a->{msg}; $a->{me} ||= 0; $a->{time} ||= strftime($TIMESTAMP,localtime()); _log $a->{channel}, " ", $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">", - " " . $a->{msg}; - - from_to($a->{msg}, 'UTF-8', $ENCODING); + " " . $a->{message}; - $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time}); - add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), - message => $a->{msg}); + $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time}); + add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a ); } if ($import_dircproxy) { open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!"; warn "importing $import_dircproxy...\n"; - my $tz_offset = 2 * 60 * 60; # TZ GMT+2 + my $tz_offset = 1 * 60 * 60; # TZ GMT+2 while(<$l>) { chomp; if (/^@(\d+)\s(\S+)\s(.+)$/) { @@ -493,7 +647,7 @@ channel => $CHANNEL, me => $me, nick => $nick, - msg => $msg, + message => $msg, time => $dt->ymd . " " . $dt->hms, ) if ($nick !~ m/^-/); @@ -506,28 +660,162 @@ 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); +my $_stat; + + +sub rss_fetch { + my ($args) = @_; + + # how many messages to send out when feed is seen for the first time? + my $send_rss_msgs = 1; + + _log "RSS fetch", $args->{url}; + + my $feed = XML::Feed->parse(URI->new( $args->{url} )); + if ( ! $feed ) { + _log("can't fetch RSS ", $args->{url}); + 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 ",$feed->link 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 ); + if ( my $tags = $entry->category ) { + $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(">> $type $to", $msg); +# $args->{kernel}->post( $irc => $type => $to, $msg ); + # XXX enqueue message to send later + sub enqueue_post { + my $post = dump( @_ ); + warn "## queue_post $post\n" if $debug; + $dq->enqueue_string( $post ); + } + enqueue_post( $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 got $total items of which $updates new"; + + return $updates; +} + +sub rss_fetch_all { + my $kernel = shift; + 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 $kernel; + my $sth = $dbh->prepare( $sql ); + $sth->execute(); + warn "# ",$sth->rows," active RSS feeds\n"; + my $count = 0; + while (my $row = $sth->fetchrow_hashref) { + $row->{kernel} = $kernel if $kernel; + $count += rss_fetch( $row ); + } + return "OK, fetched $count posts from " . $sth->rows . " feeds"; +} + + +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 ); + } + # XXX send queue messages + while ( my $job = $dq->pickup_queued_job() ) { + my $data = read_file( $job->get_data_path ) || die "can't load ", $job->get_data_path, ": $!"; +# $kernel->post( $irc => $type => $to, $msg ); + my @data = eval $data; + _log ">> post from queue ", $irc, @data; + $kernel->post( $irc => @data ); + $job->finish; + warn "## done queued job: ",dump( @data ) if $debug; + } +} + +# seed rss seen cache so we won't send out all items on startup +_log rss_fetch_all if ! $debug; + +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; + undef; + }, 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" ); + $_[KERNEL]->post( $irc => join => $CHANNEL); }, irc_public => sub { my $kernel = $_[KERNEL]; @@ -535,8 +823,9 @@ my $channel = $_[ARG1]->[0]; my $msg = $_[ARG2]; - save_message( channel => $channel, me => 0, nick => $nick, msg => $msg); + 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]; @@ -544,29 +833,32 @@ my $channel = $_[ARG1]->[0]; my $msg = $_[ARG2]; - save_message( channel => $channel, me => 1, nick => $nick, msg => $msg); + save_message( channel => $channel, me => 1, nick => $nick, message => $msg); - if ( my $twitter = meta( $nick, $channel, 'twitter' ) ) { - my ($login,$passwd) = split(/\s+/,$twitter,2); - _log("sending twitter for $nick/$login on $channel "); - my $bot = Net::Twitter->new( username=>$login, password=>$passwd ); - $bot->update("<${channel}> $msg"); + if ( $use_twitter ) { + if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) { + my ($login,$passwd) = split(/\s+/,$twitter,2); + _log("sending twitter for $nick/$login on $channel "); + my $bot = Net::Twitter->new( username=>$login, password=>$passwd ); + $bot->update("<${channel}> $msg"); + } } }, 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 { @@ -574,7 +866,7 @@ my $nick = (split /!/, $_[ARG0])[0]; my $msg = $_[ARG2]; my $channel = $_[ARG1]->[0]; - from_to($msg, 'UTF-8', $ENCODING); + warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug; my $res = "unknown command '$msg', try /msg $NICK help!"; my @out; @@ -585,10 +877,10 @@ $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) { + } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) { - _log ">> /msg $1 $2"; - $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 ); + _log ">> /$1 $2 $3"; + $_[KERNEL]->post( $irc => $1 => $2, $3 ); $res = ''; } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) { @@ -597,11 +889,11 @@ my $sth = $dbh->prepare(qq{ select - nick, + trim(both '_' from nick) as nick, count(*) as count, sum(length(message)) as len from log - group by nick + group by trim(both '_' from nick) order by len desc,count desc limit $nr }); @@ -618,8 +910,7 @@ foreach my $res (get_from_log( limit => $limit )) { _log "last: $res"; - from_to($res, $ENCODING, 'UTF-8'); - $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res ); + $_[KERNEL]->post( $irc => privmsg => $nick, $res ); } $res = ''; @@ -633,8 +924,7 @@ search => $what, )) { _log "search [$what]: $res"; - from_to($res, $ENCODING, 'UTF-8'); - $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res ); + $_[KERNEL]->post( $irc => privmsg => $nick, $res ); } $res = ''; @@ -669,10 +959,10 @@ " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" . " from " . ( join(", ", @nicks) || 'nobody' ); - $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res ); + $_[KERNEL]->post( $irc => notice => $nick, $res ); } elsif ($msg =~ m/^ping/) { - $res = "ping = " . dump( $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 = ? }); @@ -703,43 +993,134 @@ $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 name = ? }, + 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 ); + } + warn "## $command SQL $q with ",dump( @data ),"\n"; + eval { $sth->execute( @data ) }; + if ($@) { + $res = "ERROR: $@"; + } else { + $res = "OK, RSS executed $command " . ( $sub ? "-$sub" : '' ) ."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"; + } + } + } + } + } 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 = "OK, cleaned RSS cache"; } 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", @@ -749,80 +1130,24 @@ ""; 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 - } - - }, - my_heartbeat => sub { - $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep"); - $_[KERNEL]->delay($_[STATE] => 10); - } }, ); # http server +_log "WEB archive at $url"; + my $httpd = POE::Component::Server::HTTP->new( - Port => $NICK =~ m/-dev/ ? 8001 : 8000, + Port => $http_port, + PreHandler => { + '/' => sub { + $_[0]->header(Connection => 'close') + } + }, ContentHandler => { '/' => \&root_handler }, Headers => { Server => 'irc-logger' }, ); -my %escape = ('<'=>'<', '>'=>'>', '&'=>'&', '"'=>'"'); -my $escape_re = join '|' => keys %escape; - my $style = <<'_END_OF_STYLE_'; p { margin: 0; padding: 0.1em; } .time, .channel { color: #808080; font-size: 60%; } @@ -830,24 +1155,44 @@ .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; } .message { color: #000000; font-size: 100%; } .search { float: right; } +a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none } +a:hover.tag { border: 1px solid #eee } +hr { border: 1px dashed #ccc; height: 1px; clear: both; } +/* .col-0 { background: #ffff66 } .col-1 { background: #a0ffff } .col-2 { background: #99ff99 } .col-3 { background: #ff9999 } .col-4 { background: #ff66ff } -a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none } -a:hover.tag { border: 1px solid #eee } -hr { border: 1px dashed #ccc; height: 1px; clear: both; } +*/ +.calendar { border: 1px solid red; width: 100%; } +.month { border: 0px; width: 100%; } _END_OF_STYLE_ -my $max_color = 4; +$max_color = 0; -my %nick_enumerator; +my @cols = qw( + #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99 + #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66 + #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399 + #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00 + #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff +); + +foreach my $c (@cols) { + $style .= ".col-${max_color} { background: $c }\n"; + $max_color++; +} +_log "WEB defined $max_color colors for users..."; sub root_handler { my ($request, $response) = @_; $response->code(RC_OK); - $response->content_type("text/html; charset=$ENCODING"); + + # 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; @@ -860,55 +1205,192 @@ } 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; + + my $type = 'RSS'; # Atom + + $response->content_type( 'application/' . lc($type) . '+xml' ); + + my $html = ''; + #warn "create $type feed from ",dump( @last_tags ); + + my $feed = XML::Feed->new( $type ); + $feed->link( $url ); + + 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( "$nr tags from $CHANNEL" ); + $feed_entry->author( $NICK ); + $feed_entry->link( '/#tags' ); + + $feed_entry->content( + qq{} + . $cloud->css + . qq{} + . $cloud->html( $nr ) + . qq{]]>} + ); + $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; + } + + if ( $@ ) { + warn "$@"; + } + + $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 + select date(time) as date,count(*) as nr,sum(length(message)) as len from log group by date(time) order by date(time) desc }); $sth->execute(); my ($l_yyyy,$l_mm) = (0,0); + $html .= qq{}; my $cal; + my $ord = 0; while (my $row = $sth->fetchrow_hashref) { # this is probably PostgreSQL specific, expects ISO date my ($yyyy,$mm,$dd) = split(/-/, $row->{date}); if ($yyyy != $l_yyyy || $mm != $l_mm) { - $html .= $cal->as_HTML() if ($cal); + if ( $cal ) { + $html .= qq{}; + $ord++; + $html .= qq{} if ( $ord % 3 == 0 ); + } $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy); - $cal->border(2); + $cal->border(1); + $cal->width('30%'); + $cal->cellheight('5em'); + $cal->tableclass('month'); + #$cal->cellclass('day'); + $cal->sunday('SUN'); + $cal->saturday('SAT'); + $cal->weekdays('MON','TUE','WED','THU','FRI'); ($l_yyyy,$l_mm) = ($yyyy,$mm); } - $cal->setcontent($dd, qq{ - $row->{nr} - }); + $cal->setcontent($dd, qq[ + $row->{nr}
$row->{len} + ]) if $cal; + } - $html .= $cal->as_HTML() if ($cal); + $html .= qq{
} . $cal->as_HTML() . qq{
} . $cal->as_HTML() . qq{
}; } else { $html .= join("

", get_from_log( - limit => $q->param('last') || $q->param('date') ? undef : 100, + limit => ( $q->param('last') || $q->param('date') ) ? undef : 100, search => $search || undef, tag => $q->param('tag') || undef, date => $q->param('date') || undef, fmt => { date => sub { my $date = shift || return; - qq{


$date
}; + qq{
$date
}; }, time => '%s ', time_channel => '%s %s ', @@ -916,25 +1398,7 @@ me_nick => '***%s ', message => '%s', }, - filter => { - message => sub { - my $m = shift || return; - $m =~ s/($escape_re)/$escape{$1}/gs; - $m =~ s#($RE{URI}{HTTP})#$1#gs; - $m =~ s#$tag_regex#$1#g; - return $m; - }, - nick => sub { - my $n = shift || return; - if (! $nick_enumerator{$n}) { - my $max = scalar keys %nick_enumerator; - $nick_enumerator{$n} = $max + 1; - } - return '' . $n . ''; - }, - }, + filter => $filter, ) ); } @@ -945,6 +1409,7 @@ }; $response->content( $html ); + warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n"; return RC_OK; }