--- trunk/bin/irc-logger.pl 2008/03/07 11:16:05 95 +++ 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 @@ -30,19 +48,39 @@ ## CONFIG +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"; + +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; @@ -62,23 +100,6 @@ ## END CONFIG -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; - my $use_twitter = 1; eval { require Net::Twitter; }; $use_twitter = 0 if ($@); @@ -88,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: $!"; - 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 = ('<'=>'<', '>'=>'>', '&'=>'&', '"'=>'"'); @@ -117,11 +140,11 @@ # 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#\*(\w+)\*#$1#gs; @@ -142,6 +165,13 @@ }, }; +# 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' } ); @@ -178,12 +208,15 @@ 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) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki'); +insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin'); }, }; @@ -336,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; @@ -368,6 +402,8 @@ eval { $sth->execute( @args ) }; return if $@; + my $nr_results = $sth->rows; + my $last_row = { date => '', time => '', @@ -388,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 = (); @@ -448,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}; @@ -563,12 +605,13 @@ $a->{me} ||= 0; $a->{time} ||= strftime($TIMESTAMP,localtime()); - _log + _log "ARCHIVE", $a->{channel}, " ", $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">", " " . $a->{message}; - $sth_insert_log->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 ); } @@ -611,29 +654,49 @@ # RSS follow # -my $_rss; +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_fetch { - my ($args) = @_; +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 = 1; + my $send_rss_msgs = $args->{send_rss_msgs}; + $send_rss_msgs = 1 if ! defined $send_rss_msgs; - _log "RSS fetch", $args->{url}; + warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug; - my $feed = XML::Feed->parse(URI->new( $args->{url} )); + my $feed = XML::Feed->parse( \$args->{xml} ); if ( ! $feed ) { - _log("can't fetch RSS ", $args->{url}); + _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? - next if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0; + warn "## $seen_times ",$entry->id if $debug; + next if $seen_times > 0; sub prefix { my ($txt,$var) = @_; @@ -652,7 +715,6 @@ } elsif ( $link !~ m!^http! ) { $link = $args->{url} . $link; } - $link =~ s!//+!/!g; my $msg; $msg .= prefix( 'From: ' , $args->{name} || $feed->title ); @@ -660,12 +722,29 @@ $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 ( $args->{kernel} && $send_rss_msgs ) { + if ( $seen_times == 0 && $send_rss_msgs ) { $send_rss_msgs--; - _log('>>', $msg); - $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, 'now()' ); - $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg ); + 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++; } } @@ -675,63 +754,263 @@ $sql .= qq{where id = } . $args->{id}; eval { $dbh->do( $sql ) }; - _log "RSS got $total items of which $updates new"; + _log "RSS $updates/$total new items from", $args->{url}; return $updates; } sub rss_fetch_all { - my $kernel = shift; + 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 + 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; + $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->{kernel} = $kernel if $kernel; - $count += rss_fetch( $row ); + $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, fetched $count posts from " . $sth->rows . " feeds"; + return "OK, scheduled " . $sth->rows . " feeds for refresh"; } sub rss_check_updates { my $kernel = shift; - $_rss->{last_poll} ||= time(); - my $dt = time() - $_rss->{last_poll}; - warn "## rss_check_updates $dt > $rss_min_delay\n"; + $_stat->{rss}->{last_poll} ||= time(); + my $dt = time() - $_stat->{rss}->{last_poll}; if ( $dt > $rss_min_delay ) { - $_rss->{last_poll} = time(); + warn "## rss_check_updates $dt > $rss_min_delay\n"; + $_stat->{rss}->{last_poll} = time(); _log rss_fetch_all( $kernel ); } } -# seed rss seen cache so we won't send out all items on startup -_log rss_fetch_all; +sub process_command { + my ( $kernel, $nick, $channel, $msg ) = @_; -# -# POE handing part -# + 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"; -my $ping; # ping stats + } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) { -POE::Component::IRC->new($IRC_ALIAS); + _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_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 => privmsg => 'nickserv', "IDENTIFY $NICK" ); + $_[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]; @@ -762,7 +1041,7 @@ }, irc_ping => sub { _log( "pong ", $_[ARG0] ); - $ping->{ $_[ARG0] }++; + $_stat->{ping}->{ $_[ARG0] }++; rss_check_updates( $_[KERNEL] ); }, irc_invite => sub { @@ -772,221 +1051,114 @@ _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]; - - 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"; - $_[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"; - $_[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"; - } - } - } elsif ($msg =~ m/^rss-update/) { - $res = rss_fetch_all( $_[KERNEL] ); - } elsif ($msg =~ m/^rss-clean/) { - $_rss = undef; - $dbh->do( qq{ update feeds set last_update = now() - delay } ); - $res = "OK, cleaned RSS cache"; - } elsif ($msg =~ m/^rss-list/) { - my $sth = $dbh->prepare(qq{ select url,name,last_update,active from feeds }); - $sth->execute; - while (my @row = $sth->fetchrow_array) { - $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) ); - } - $res = ''; - } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) { - my $sql = { - add => qq{ insert into feeds (url,name) 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 = ? }, - }; - if (my $q = $sql->{$1} ) { - my $sth = $dbh->prepare( $q ); - my @data = ( $2 ); - push @data, $3 if ( $q =~ s/\?//g == 2 ); - warn "## $1 SQL $q with ",dump( @data ),"\n"; - eval { $sth->execute( @data ) }; - } - - $res = "OK, RSS $1 : $2 - $3"; - } + my $res = process_command( $_[KERNEL], $nick, $channel, $msg ); if ($res) { _log ">> [$nick] $res"; - $_[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 + _log '_default SID:', $_[SESSION]->ID, $_[ARG0], dump( $_[ARG1] ); + 0; # false for signals }, + 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 => { @@ -1033,7 +1205,7 @@ $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) = @_; @@ -1055,8 +1227,12 @@ } 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 ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) { + if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) { my $show = lc($1); my $nr = $2; @@ -1070,6 +1246,8 @@ my $feed = XML::Feed->new( $type ); $feed->link( $url ); + my $rc = RC_OK; + if ( $show eq 'tags' ) { $nr ||= 50; $feed->title( "tags from $CHANNEL" ); @@ -1139,13 +1317,29 @@ $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 "unknown rss request ",$request->url; - return RC_DENY; + _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 ( $@ ) { @@ -1236,7 +1430,7 @@

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; }