trunk/bin/irc-logger.pl

#!/usr/bin/perl -w
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 IPC::DirQueue;
use File::Slurp;
use Encode;

=head1 NAME

irc-logger.pl

=head1 SYNOPSIS

./irc-logger.pl

=head2 Options

=over 4

=item --import-dircproxy=filename

Import log from C<dircproxy> to C<irc-logger> database

=item --log=irc-logger.log

=back

=head1 DESCRIPTION

log all conversation on irc channel

=cut

## 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 $queue_dir = './queue';

my $HOSTNAME = `hostname -f`;
chomp($HOSTNAME);


my $CHANNEL = '#razmjenavjestina';

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 $TIMESTAMP = '%Y-%m-%d %H:%M:%S';

my $sleep_on_error = 5;

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

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,
        'debug!' => \$debug,
);

#$SIG{__DIE__} = sub {
#       confess "fatal error";
#};

sub _log {
        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 = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
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{<a href="$1">$1</a>})#egs;
                $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
                $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
                $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
                $m =~ s#_(\w+)_#<u>$1</u>#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 '<span class="nick col-' .
                        ( $nick_enumerator{$n} % $max_color ) .
                        '">' . $n . '</span>';
        },
};

# 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 => qq{
create table log (
        id serial,
        time timestamp default now(),
        channel text not null,
        me boolean default false,
        nick text not null,
        message text not null,
        primary key(id)
);

create index log_time on log(time);
create index log_channel on log(channel);
create index log_nick on log(nick);
        },
        meta => q{
create table meta (
        nick text not null,
        channel text not null,
        name text not null,
        value text,
        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 ) {

        eval {
                $dbh->do(qq{ select count(*) from $table });
        };

        if ($@) {
                warn "creating database table $table in $DSN\n";
                $dbh->do( $sql_schema->{ $table } );
        }
}


=head2 meta

Set or get some meta data into database

        meta('nick','channel','var_name', $var_value );

        $var_value = meta('nick','channel','var_name');
        ( $var_value, $changed ) = meta('nick','channel','var_name');

=cut

sub meta {
        my ($nick,$channel,$name,$value) = @_;

        # normalize channel name
        $channel =~ s/^#//;

        if (defined($value)) {

                my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });

                eval { $sth->execute( $value, $nick, $channel, $name ) };

                # error or no result
                if ( $@ || ! $sth->rows ) {
                        $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
                        $sth->execute( $value, $nick, $channel, $name );
                        warn "## created $nick/$channel/$name = $value\n";
                } else {
                        warn "## updated $nick/$channel/$name = $value\n";
                }

                return $value;

        } else {

                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;
                warn "## fetched $nick/$channel/$name = $v [$c]\n";
                return ($v,$c) if wantarray;
                return $v;

        }
}


my $sth_insert_log = $dbh->prepare(qq{
insert into log
        (channel, me, nick, message, time)
values (?,?,?,?,?)
});


my $tags;

=head2 get_from_log

 my @messages = get_from_log(
        limit => 42,
        search => '%what to stuff in ilike%',
        fmt => {
                time => '{%s} ',
                time_channel => '{%s %s} ',
                nick => '%s: ',
                me_nick => '***%s ',
                message => '%s',
        },
        filter => {
                message => sub {
                        # modify message content
                        return shift;
                }
        },
        context => 5,
        full_rows => 1,
 );

Order is important. Fields are first passed through C<filter> (if available) and
then throgh C<< sprintf($fmt->{message}, $message >> if available.

C<context> defines number of messages around each search hit for display.

C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
C<me>, C<nick> and C<message> keys.

=cut

sub get_from_log {
        my $args = {@_};

        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
                        time::date as date,
                        time::time as time,
                        channel,
                        me,
                        nick,
                        message
                from log
        };

        my $sql_context = qq{
                select
                        id
                from log
        };

        my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);

        my $sql = $context ? $sql_context : $sql_message;

        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;

        if (my $search = $args->{search}) {
                $search =~ s/^\s+//;
                $search =~ s/\s+$//;
                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 => '',
                channel => '',
                nick => '',
        };

        my @rows;

        while (my $row = $sth->fetchrow_hashref) {
                unshift @rows, $row;
        }

        # normalize nick names
        map {
                $_->{nick} =~ s/^_*(.*?)_*$/$1/
        } @rows;

        return @rows if ($args->{full_rows});

        $msg .= ' produced ' . (
                $nr_results == 0 ? 'no results' :
                $nr_results == 0 ? 'one result' :
                        $nr_results . ' results'
        );

        my @msgs = ( $msg );

        if ($context) {
                my @ids = @rows;
                @rows = ();

                my $last_to = 0;

                my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
                foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
                        my $id = $row_id->{id} || die "can't find id in row";
        
                        my ($from, $to) = ($id - $context, $id + $context);
                        $from = $last_to if ($from < $last_to);
                        $last_to = $to;
                        $sth->execute( $from, $to );

                        #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";

                        while (my $row = $sth->fetchrow_hashref) {
                                push @rows, $row;
                        }

                }
        }

        # sprintf which can take coderef as first parametar
        sub cr_sprintf {
                my $fmt = shift || return;
                if (ref($fmt) eq 'CODE') {
                        $fmt->(@_);
                } else {
                        sprintf($fmt, @_);
                }
        }

        foreach my $row (@rows) {

                $row->{time} =~ s#\.\d+##;

                my $msg = '';

                $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
                my $t = $row->{time};

                if ($last_row->{channel} ne $row->{channel}) {
                        $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
                } else {
                        $msg .= cr_sprintf($args->{fmt}->{time}, $t);
                }

                my $append = 1;

                my $nick = $row->{nick};
#               if ($nick =~ s/^_*(.*?)_*$/$1/) {
#                       $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};
                        $fmt ||= '%s';

                        $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');

                        $msg .= cr_sprintf( $fmt, $nick );
                        $append = 0;
                }

                $args->{fmt}->{message} ||= '%s';
                if (ref($args->{filter}->{message}) eq 'CODE') {
                        $msg .= cr_sprintf($args->{fmt}->{message},
                                $args->{filter}->{message}->(
                                        $row->{message}
                                )
                        );
                } else {
                        $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
                }

                if ($append && @msgs) {
                        $msgs[$#msgs] .= " " . $msg;
                } else {
                        push @msgs, $msg;
                }

                $last_row = $row;
        }

        return @msgs;
}

# tags support

my $cloud = HTML::TagCloud->new;

=head2 add_tag

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

        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, "$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

Read all tags from database and create in-memory cache for tags

=cut

sub seed_tags {
        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, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
        }
}

seed_tags;


=head2 save_message

  save_message(
        channel => '#foobar',
        me => 0,
        nick => 'dpavlin',
        message => 'test message',
        time => '2006-06-25 18:57:18',
  );

C<time> is optional, it will use C<< now() >> if it's not available.

C<me> if not specified will be C<0> (not C</me> message)

=cut

sub save_message {
        my $a = {@_};
        confess "have msg" if $a->{msg};
        $a->{me} ||= 0;
        $a->{time} ||= strftime($TIMESTAMP,localtime());

        _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});
        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 = 1 * 60 * 60;    # TZ GMT+2
        while(<$l>) {
                chomp;
                if (/^@(\d+)\s(\S+)\s(.+)$/) {
                        my ($time, $nick, $msg) = ($1,$2,$3);

                        my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );

                        my $me = 0;
                        $me = 1 if ($nick =~ m/^\[\S+]/);
                        $nick =~ s/^[\[<]([^!]+).*$/$1/;

                        $msg =~ s/^ACTION\s+// if ($me);

                        save_message(
                                channel => $CHANNEL,
                                me => $me,
                                nick => $nick,
                                message => $msg,
                                time => $dt->ymd . " " . $dt->hms,
                        ) if ($nick !~ m/^-/);

                } else {
                        _log "can't parse: $_";
                }
        }
        close($l);
        warn "import over\n";
        exit;
}

#
# RSS follow
#

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 ($args) = @_;

        warn "## rss_parse_xml ",dump( @_ ) 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;

        _log "RSS fetch first $send_rss_msgs items from", $args->{url};

        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 );
                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("RSS generated $type to $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 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 );
        }
        # 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, ": $!";
                my @data = eval $data;
                _log "IRC post from queue:", @data;
                $kernel->post( $irc => @data );
                $job->finish;
                warn "## done queued job: ",dump( @data ) 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;
                # 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];
                my $channel = $_[ARG1]->[0];
                my $msg = $_[ARG2];

                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];
                my $nick = (split /!/, $_[ARG0])[0];
                my $channel = $_[ARG1]->[0];
                my $msg = $_[ARG2];

                save_message( channel => $channel, me => 1, nick => $nick, message => $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 {
                _log( "pong ", $_[ARG0] );
                $_stat->{ping}->{ $_[ARG0] }++;
                rss_check_updates( $_[KERNEL] );
        },
        irc_invite => sub {
                my $kernel = $_[KERNEL];
                my $nick = (split /!/, $_[ARG0])[0];
                my $channel = $_[ARG1];

                _log "invited to $channel by $nick";

                $_[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];
                warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;

                my $res = "unknown command '$msg', try /msg $NICK help!";
                my @out;

                _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/^(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 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";
                        $_[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];
                _log ">> IDENTIFY $NICK";
                $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
        },
        irc_505 => sub {
                _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 "<< registered $NICK";
        },
        irc_disconnected => sub {
                _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 => 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);
                }
        },
    _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
    },
        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( $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' },
);

my $style = <<'_END_OF_STYLE_';
p { margin: 0; padding: 0.1em; }
.time, .channel { color: #808080; font-size: 60%; }
.date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
.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 }
*/
.calendar { border: 1px solid red; width: 100%; }
.month { border: 0px; width: 100%; }
_END_OF_STYLE_

$max_color = 0;

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

        # 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' ) {
                $q = new CGI::Simple( $request->content );
        } elsif ( $request->uri =~ /\?(.+)$/ ) {
                $q = new CGI::Simple( $1 );
        } else {
                $q = new CGI::Simple;
        }

        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 = '<!-- error -->';
                #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{<![CDATA[<style type="text/css">}
                                . $cloud->css
                                . qq{</style>}
                                . $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 .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
#                               warn "## message = $message\n";

                                #$feed_entry->summary(
                                $feed_entry->content(
                                        "<![CDATA[$message]]>"
                                );
                                $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(
                                        '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
                                );
                                $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(
                                '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
                        );
                        $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{<html><head><title>$NICK</title><style type="text/css">$style}
                . $cloud->css
                . qq{</style></head><body>}
                . qq{
                <form method="post" class="search" action="/">
                <input type="text" name="search" value="$search" size="10">
                <input type="submit" value="search">
                </form>
                }
                . $cloud->html(500)
                . qq{<p>};

        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
                                group by date(time)
                                order by date(time) desc
                });
                $sth->execute();
                my ($l_yyyy,$l_mm) = (0,0);
                $html .= qq{<table class="calendar"><tr>};
                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) {
                                if ( $cal ) {
                                        $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
                                        $ord++;
                                        $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
                                }
                                $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
                                $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[
                                <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
                        ]) if $cal;
                        
                }
                $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};

        } else {
                $html .= join("</p><p>",
                        get_from_log(
                                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{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
                                        },
                                        time => '<span class="time">%s</span> ',
                                        time_channel => '<span class="channel">%s %s</span> ',
                                        nick => '%s:&nbsp;',
                                        me_nick => '***%s&nbsp;',
                                        message => '<span class="message">%s</span>',
                                },
                                filter => $filter,
                        )
                );
        }

        $html .= qq{</p>
        <hr/>
        <p>See <a href="/history">history</a> of all messages.</p>
        </body></html>};

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

POE::Kernel->run;