--- trunk/irc-logger.pl 2006/03/12 13:33:20 12
+++ trunk/bin/irc-logger.pl 2011/10/08 18:33:36 149
@@ -2,6 +2,24 @@
use strict;
$|++;
+use POE qw(Component::IRC Component::Server::HTTP Component::Client::HTTP);
+use HTTP::Status;
+use DBI;
+use Regexp::Common qw /URI/;
+use CGI::Simple;
+use POSIX qw/strftime/;
+use HTML::CalendarMonthSimple;
+use Getopt::Long;
+use DateTime;
+use URI::Escape;
+use Data::Dump qw/dump/;
+use DateTime::Format::ISO8601;
+use Carp qw/confess/;
+use XML::Feed;
+use DateTime::Format::Flexible;
+use Encode;
+#use Redis 2.0;
+
=head1 NAME
irc-logger.pl
@@ -10,6 +28,18 @@
./irc-logger.pl
+=head2 Options
+
+=over 4
+
+=item --import-dircproxy=filename
+
+Import log from C to C database
+
+=item --log=irc-logger.log
+
+=back
+
=head1 DESCRIPTION
log all conversation on irc channel
@@ -18,41 +48,141 @@
## CONFIG
-my $NICK = 'irc-logger-dev';
-my $CONNECT =
- {Server => 'irc.freenode.net',
- Nick => $NICK,
- Ircname => "try /msg $NICK help",
- };
+my $debug = 0;
+
+my $irc_config = {
+ nick => 'irc-logger',
+ server => 'irc.freenode.net',
+ port => 6667,
+ ircname => 'Anna the bot: try /msg irc-logger help',
+};
+
+my $HOSTNAME = `hostname -f`;
+chomp($HOSTNAME);
+
+
my $CHANNEL = '#razmjenavjestina';
-my $IRC_ALIAS = "log";
-my %FOLLOWS =
- (
- ACCESS => "/var/log/apache/access.log",
- ERROR => "/var/log/apache/error.log",
- );
+if ( $HOSTNAME =~ m/llin/ ) {
+ $irc_config->{nick} = 'irc-logger-llin';
+# $irc_config = {
+# nick => 'irc-logger-llin',
+# server => 'localhost',
+# port => 6668,
+# };
+ $CHANNEL = '#irc-logger';
+} elsif ( $HOSTNAME =~ m/lugarin/ ) {
+ $irc_config->{server} = 'irc.carnet.hr';
+ $CHANNEL = '#riss';
+}
+
+my @channels = ( $CHANNEL );
+
+warn "## config = ", dump( $irc_config ) if $debug;
+
+my $NICK = $irc_config->{nick} or die "no nick?";
+
+my $DSN = 'DBI:Pg:dbname=' . $NICK;
-my $DSN = 'DBI:Pg:dbname=irc-logger';
+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,
+ 'debug!' => \$debug,
+);
+
+#$SIG{__DIE__} = sub {
+# confess "fatal error";
+#};
+sub _log {
+ print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
+}
-use POE qw(Component::IRC Wheel::FollowTail);
-use DBI;
-use Encode qw/from_to/;
+open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
-my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
+# HTML formatters
+
+my %escape = ('<'=>'<', '>'=>'>', '&'=>'&', '"'=>'"');
+my $escape_re = join '|' => keys %escape;
+
+my $tag_regex = '\b([\w\-_]+)//';
+
+my %nick_enumerator;
+my $max_color = 0;
+
+my $filter = {
+ message => sub {
+ my $m = shift || return;
+
+ # protect HTML from wiki modifications
+ sub e {
+ my $t = shift;
+ eval { $t = 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}'; };
+ return $t;
+ }
+
+ $m =~ s/($escape_re)/$escape{$1}/gs;
+ $m =~ s#($RE{URI}{HTTP})#e(qq{$1})#egs;
+# $m =~ s#\/(\w+)\/#$1#gs;
+ $m =~ s#$tag_regex#e(qq{$1})#egs;
+ $m =~ s#\*(\w+)\*#$1#gs;
+ $m =~ s#_(\w+)_#$1#gs;
+
+ $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
+ return $m;
+ },
+ nick => sub {
+ my $n = shift || return;
+ if (! $nick_enumerator{$n}) {
+ my $max = scalar keys %nick_enumerator;
+ $nick_enumerator{$n} = $max + 1;
+ }
+ return '' . $n . '';
+ },
+};
-=for SQL schema
+# 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' } );
-$dbh->do(qq{
+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)
@@ -61,50 +191,227 @@
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
-my $sth = $dbh->prepare(qq{
+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 ) };
+
+ if ( $@ ) {
+ # error
+ _log("META ERROR: $@");
+ } elsif ( ! $sth->rows ) {
+ # no result -> add new
+ $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
+ eval { $sth->execute( $value, $nick, $channel, $name ); };
+ if ( $@ ) {
+ _log "META ERROR: $@";
+ } else {
+ _log "META: created $nick/$channel/$name = $value\n";
+ }
+ } else {
+ _log "META: 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, nick, message)
-values (?,?,?)
+ (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 (if available) and
+then throgh C<< sprintf($fmt->{message}, $message >> if available.
+
+C defines number of messages around each search hit for display.
+
+C will return database rows for each result with C, C
",
+ get_from_log(
+ limit => ( $q->param('date') ? undef : $q->param('last') || 100 ),
+ search => $search || undef,
+ tag => $q->param('tag') || undef,
+ date => $q->param('date') || undef,
+ fmt => {
+ date => sub {
+ my $date = shift || return;
+ qq{
};
+ },
+ time => '%s ',
+ time_channel => '%s %s ',
+ nick => '%s: ',
+ me_nick => '***%s ',
+ message => '%s',
+ },
+ filter => $filter,
+ )
+ );
+ }
+
+ $html .= qq{
+
+ See history of all messages.
+ };
+
+ $response->content( $html );
+ warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
+ return RC_OK;
+}
+
POE::Kernel->run;
+
+=head1 TagCloud
+
+Extended L
+
+=cut
+
+package TagCloud;
+use warnings;
+use strict;
+use HTML::TagCloud;
+use base 'HTML::TagCloud';
+use Data::Dump qw/dump/;
+
+=head2 html
+
+Generate html with number of tags in title of link
+
+=cut
+
+sub html {
+ my($self, $limit) = @_;
+ my @tags=$self->tags($limit);
+
+ my $ntags = scalar(@tags);
+ if ($ntags == 0) {
+ return "";
+# } elsif ($ntags == 1) {
+# my $tag = $tags[0];
+# return qq{\n};
+ }
+
+ my $html = qq{};
+ foreach my $tag ( sort { lc($a->{name}) cmp lc($b->{name}) } @tags) {
+ $html .= sprintf(qq{
%s\n},
+ $tag->{level}, $tag->{url}, $tag->{count}, $tag->{name}
+ );
+ }
+ $html .= qq{
};
+ return $html;
+}
+
+=head2 last_tags
+
+ my @tags = $cloud->last_tags;
+
+=cut
+
+my @last_tags;
+sub last_tags {
+ return @last_tags;
+}
+
+=head2 add_tag
+
+ $cloud->add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
+
+=cut
+
+
+sub add_tag {
+ my $self = shift;
+ 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";
+ $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
+ 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 $self = shift;
+ 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) {
+ $self->add_tag( %$row );
+ }
+
+ foreach my $tag (keys %$tags) {
+ $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
+ }
+}
+