trunk/bin/irc-logger.pl

#!/usr/bin/perl -w
use strict;
$|++;

=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

Name of log file

=item --follow=file.log

Follows new messages in file

=back

=head1 DESCRIPTION

log all conversation on irc channel

=cut

## CONFIG

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

# default log to follow and announce messages
my $follows_path = 'follows.log';

my $DSN = 'DBI:Pg:dbname=' . $NICK;

my $ENCODING = 'ISO-8859-2';
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;

my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;

my $url = "http://$HOSTNAME:$http_port";

## END CONFIG


use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
use HTTP::Status;
use DBI;
use Encode qw/from_to is_utf8/;
use Regexp::Common qw /URI/;
use CGI::Simple;
use HTML::TagCloud;
use POSIX qw/strftime/;
use HTML::CalendarMonthSimple;
use Getopt::Long;
use DateTime;
use URI::Escape;
use Data::Dump qw/dump/;
use DateTime::Format::ISO8601;
use Carp qw/confess/;
use XML::Feed;
use DateTime::Format::Flexible;

my $use_twitter = 1;
eval { require Net::Twitter; };
$use_twitter = 0 if ($@);

my $import_dircproxy;
my $log_path;
GetOptions(
        'import-dircproxy:s' => \$import_dircproxy,
        'follows:s' => \$follows_path,
        'log:s' => \$log_path,
);

$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(" ",@_), $/;
}

# LOG following

my %FOLLOWS =
  (
#   ACCESS => "/var/log/apache/access.log",
#   ERROR => "/var/log/apache/error.log",
  );

sub add_follow_path {
        my $path = shift;
        my $name = $path;
        $name =~ s/\..*$//;
        warn "# using $path to announce messages from $name\n";
        $FOLLOWS{$name} = $path;
}

add_follow_path( $follows_path ) if ( -e $follows_path );

# 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) . '}';
                }

                $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>';
        },
};

my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;

my $sql_schema = {
        log => '
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 => '
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)
);
        ',
};

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 );
                        _log "created $nick/$channel/$name = $value";
                } else {
                        _log "updated $nick/$channel/$name = $value ";
                }

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

        }
}


my $sth = $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;

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

        if ($args->{tag} && $tags->{ $args->{tag} }) {
                push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
                _log "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";
        }

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

        my @msgs = (
                "Showing " . ($#rows + 1) . " messages..."
        );

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

                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};
        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, "$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
                $a->{channel}, " ",
                $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
                " " . $a->{message};

        from_to($a->{message}, 'UTF-8', $ENCODING);

        $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
        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;
}


#
# POE handing part
#

my $SKIPPING = 0;               # if skipping, how many we've done
my $SEND_QUEUE;                 # cache
my $ping;                                               # ping stats

POE::Component::IRC->new($IRC_ALIAS);

POE::Session->create( inline_states =>
   {_start => sub {      
                $_[KERNEL]->post($IRC_ALIAS => register => 'all');
                $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
    },
    irc_255 => sub {    # server is done blabbing
                $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
                $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
                $_[KERNEL]->yield("heartbeat"); # start heartbeat
                $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
                $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
    },
    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 );
    },
    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] );
                $ping->{ $_[ARG0] }++;
        },
        irc_invite => sub {
                my $kernel = $_[KERNEL];
                my $nick = (split /!/, $_[ARG0])[0];
                my $channel = $_[ARG1];

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

        },
        irc_msg => sub {
                my $kernel = $_[KERNEL];
                my $nick = (split /!/, $_[ARG0])[0];
                my $msg = $_[ARG2];
                my $channel = $_[ARG1]->[0];
                from_to($msg, 'UTF-8', $ENCODING);

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

                _log "<< $msg";

                if ($msg =~ m/^help/i) {

                        $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";

                } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {

                        _log ">> /msg $1 $2";
                        $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
                        $res = '';

                } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {

                        my $nr = $1 || 10;

                        my $sth = $dbh->prepare(qq{
                                select
                                        trim(both '_' from nick) as nick,
                                        count(*) as count,
                                        sum(length(message)) as len
                                from log
                                group by trim(both '_' from nick)
                                order by len desc,count desc
                                limit $nr
                        });
                        $sth->execute();
                        $res = "Top $nr users: ";
                        my @users;
                        while (my $row = $sth->fetchrow_hashref) {
                                push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
                        }
                        $res .= join(" | ", @users);
                } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {

                        my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;

                        foreach my $res (get_from_log( limit => $limit )) {
                                _log "last: $res";
                                from_to($res, $ENCODING, 'UTF-8');
                                $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
                        }

                        $res = '';

                } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {

                        my $what = $2;

                        foreach my $res (get_from_log(
                                        limit => 20,
                                        search => $what,
                                )) {
                                _log "search [$what]: $res";
                                from_to($res, $ENCODING, 'UTF-8');
                                $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
                        }

                        $res = '';

                } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {

                        my ($what,$limit) = ($1,$2);
                        $limit ||= 100;

                        my $stat;

                        foreach my $res (get_from_log(
                                        limit => $limit,
                                        search => $what,
                                        full_rows => 1,
                                )) {
                                while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
                                        $stat->{vote}->{$1}++;
                                        $stat->{from}->{ $res->{nick} }++;
                                }
                        }

                        my @nicks;
                        foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
                                push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
                                        "(" . $stat->{from}->{$nick} . ")"
                                );
                        }

                        $res =
                                "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
                                " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
                                " from " . ( join(", ", @nicks) || 'nobody' );

                        $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );

                } elsif ($msg =~ m/^ping/) {
                        $res = "ping = " . dump( $ping );
                } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
                        if ( ! defined( $1 ) ) {
                                my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
                                $sth->execute( $nick, $channel );
                                $res = "config for $nick on $channel";
                                while ( my ($n,$v) = $sth->fetchrow_array ) {
                                        $res .= " | $n = $v";
                                }
                        } elsif ( ! $2 ) {
                                my $val = meta( $nick, $channel, $1 );
                                $res = "current $1 = " . ( $val ? $val : 'undefined' );
                        } else {
                                my $validate = {
                                        'last-size' => qr/^\d+/,
                                        'twitter' => qr/^\w+\s+\w+/,
                                };

                                my ( $op, $val ) = ( $1, $2 );

                                if ( my $regex = $validate->{$op} ) {
                                        if ( $val =~ $regex ) {
                                                meta( $nick, $channel, $op, $val );
                                                $res = "saved $op = $val";
                                        } else {
                                                $res = "config option $op = $val doesn't validate against $regex";
                                        }
                                } else {
                                        $res = "config option $op doesn't exist";
                                }
                        }
                }

                if ($res) {
                        _log ">> [$nick] $res";
                        from_to($res, $ENCODING, 'UTF-8');
                        $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
                }

        },
        irc_477 => sub {
                _log "# irc_477: ",$_[ARG1];
                $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $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" );
        },
        irc_registered => sub {
                _log "## registrated $NICK";
                $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
        },
        irc_disconnected => sub {
                _log "## disconnected, reconnecting again";
                $_[KERNEL]->post($IRC_ALIAS => connect => $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);
        },
#       irc_433 => sub {
#               print "# irc_433: ",$_[ARG1], "\n";
#               warn "## indetify $NICK\n";
#               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
#       },
    _child => sub {},
    _default => sub {
                _log sprintf "sID:%s %s %s",
                        $_[SESSION]->ID, $_[ARG0],
                        ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
                        $_[ARG1]                                        ?       $_[ARG1]                                        :
                        "";
      0;                        # false for signals
    },
    my_add => sub {
      my $trailing = $_[ARG0];
      my $session = $_[SESSION];
      POE::Session->create
          (inline_states =>
           {_start => sub {
              $_[HEAP]->{wheel} =
                POE::Wheel::FollowTail->new
                    (
                     Filename => $FOLLOWS{$trailing},
                     InputEvent => 'got_line',
                    );
                                warn "+++ following $trailing at $FOLLOWS{$trailing}\n";
            },
            got_line => sub {
                                warn "+++ $trailing : $_[ARG0]\n";
                                $_[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

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++;
}
warn "defined $max_color colors for users...\n";

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

        if ($request->url =~ m#/rss(?:/(tags|last-tag)\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 );

                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->link( $url );
                        $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";
                                from_to( $message, $ENCODING, 'UTF-8' );

                                #$feed_entry->summary(
                                $feed_entry->content(
                                        "<![CDATA[$message]]>"
                                );
                                $feed_entry->category( join(', ', @{$m->{tags}}) );
                                $feed->add_entry( $feed_entry );

                                $nr--;
                                last if $nr <= 0;

                        }

                } else {
                        warn "!! unknown rss request for $show\n";
                        return RC_DENY;
                }

                $response->content( $feed->as_xml );
                return RC_OK;
        }

        if ( $@ ) {
                warn "$@";
        }

        $response->content_type("text/html; charset=$ENCODING");

        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}
                        ]);
                        
                }
                $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( $html );
        warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
        return RC_OK;
}

POE::Kernel->run;