/[irc-logger]/trunk/bin/irc-logger.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/bin/irc-logger.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 50 by dpavlin, Sun Mar 18 15:37:05 2007 UTC revision 125 by dpavlin, Fri Mar 14 15:26:33 2008 UTC
# Line 2  Line 2 
2  use strict;  use strict;
3  $|++;  $|++;
4    
5    use POE qw(Component::IRC Component::Server::HTTP Component::Client::HTTP);
6    use HTTP::Status;
7    use DBI;
8    use Regexp::Common qw /URI/;
9    use CGI::Simple;
10    use HTML::TagCloud;
11    use POSIX qw/strftime/;
12    use HTML::CalendarMonthSimple;
13    use Getopt::Long;
14    use DateTime;
15    use URI::Escape;
16    use Data::Dump qw/dump/;
17    use DateTime::Format::ISO8601;
18    use Carp qw/confess/;
19    use XML::Feed;
20    use DateTime::Format::Flexible;
21    use IPC::DirQueue;
22    use File::Slurp;
23    use Encode;
24    
25  =head1 NAME  =head1 NAME
26    
27  irc-logger.pl  irc-logger.pl
# Line 20  Import log from C<dircproxy> to C<irc-lo Line 40  Import log from C<dircproxy> to C<irc-lo
40    
41  =item --log=irc-logger.log  =item --log=irc-logger.log
42    
 Name of log file  
   
43  =back  =back
44    
45  =head1 DESCRIPTION  =head1 DESCRIPTION
# Line 32  log all conversation on irc channel Line 50  log all conversation on irc channel
50    
51  ## CONFIG  ## CONFIG
52    
53  my $HOSTNAME = `hostname`;  my $debug = 0;
54    
55    my $irc_config = {
56            nick => 'irc-logger',
57            server => 'irc.freenode.net',
58            port => 6667,
59            ircname => 'Anna the bot: try /msg irc-logger help',
60    };
61    
62    my $queue_dir = './queue';
63    
64    my $HOSTNAME = `hostname -f`;
65    chomp($HOSTNAME);
66    
67    
 my $NICK = 'irc-logger';  
 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  
 my $CONNECT =  
   {Server => 'irc.freenode.net',  
    Nick => $NICK,  
    Ircname => "try /msg $NICK help",  
   };  
68  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
 $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  
 my $IRC_ALIAS = "log";  
69    
70  my %FOLLOWS =  if ( $HOSTNAME =~ m/llin/ ) {
71    (          $irc_config->{nick} = 'irc-logger-llin';
72     ACCESS => "/var/log/apache/access.log",  #       $irc_config = {
73     ERROR => "/var/log/apache/error.log",  #               nick => 'irc-logger-llin',
74    );  #               server => 'localhost',
75    #               port => 6668,
76    #       };
77            $CHANNEL = '#irc-logger';
78    } elsif ( $HOSTNAME =~ m/lugarin/ ) {
79            $irc_config->{server} = 'irc.carnet.hr';
80            $CHANNEL = '#riss';
81    }
82    
83    my @channels = ( $CHANNEL );
84    
85    warn "## config = ", dump( $irc_config ) if $debug;
86    
87    my $NICK = $irc_config->{nick} or die "no nick?";
88    
89  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
90    
 my $ENCODING = 'ISO-8859-2';  
91  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
92    
93  my $sleep_on_error = 5;  my $sleep_on_error = 5;
94    
95  ## END CONFIG  # number of last tags to keep in circular buffer
96    my $last_x_tags = 50;
97    
98    # don't pull rss feeds more often than this
99    my $rss_min_delay = 60;
100    
101    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
102    
103  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  my $url = "http://$HOSTNAME:$http_port";
104  use HTTP::Status;  
105  use DBI;  ## END CONFIG
106  use Encode qw/from_to is_utf8/;  
107  use Regexp::Common qw /URI/;  my $use_twitter = 1;
108  use CGI::Simple;  eval { require Net::Twitter; };
109  use HTML::TagCloud;  $use_twitter = 0 if ($@);
 use POSIX qw/strftime/;  
 use HTML::CalendarMonthSimple;  
 use Getopt::Long;  
 use DateTime;  
 use Data::Dump qw/dump/;  
110    
111  my $import_dircproxy;  my $import_dircproxy;
112  my $log_path;  my $log_path;
113  GetOptions(  GetOptions(
114          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
115          'log:s' => \$log_path,          'log:s' => \$log_path,
116            'queue:s' => \$queue_dir,
117            'debug!' => \$debug,
118  );  );
119    
120  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  #$SIG{__DIE__} = sub {
121    #       confess "fatal error";
122    #};
123    
124  sub _log {  sub _log {
125          print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
126  }  }
127    
128    open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
129    
130    # queue
131    
132    if ( ! -d $queue_dir ) {
133            warn "## creating queue directory $queue_dir";
134            mkdir $queue_dir or die "can't create queue directory $queue_dir: $!";
135    }
136    
137    my $dq = IPC::DirQueue->new({ dir => $queue_dir });
138    
139    # HTML formatters
140    
141    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
142    my $escape_re  = join '|' => keys %escape;
143    
144    my $tag_regex = '\b([\w-_]+)//';
145    
146    my %nick_enumerator;
147    my $max_color = 0;
148    
149    my $filter = {
150            message => sub {
151                    my $m = shift || return;
152    
153                    # protect HTML from wiki modifications
154                    sub e {
155                            my $t = shift;
156                            return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
157                    }
158    
159                    $m =~ s/($escape_re)/$escape{$1}/gs;
160                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
161                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
162                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
163                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
164                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
165    
166                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
167                    return $m;
168            },
169            nick => sub {
170                    my $n = shift || return;
171                    if (! $nick_enumerator{$n})  {
172                            my $max = scalar keys %nick_enumerator;
173                            $nick_enumerator{$n} = $max + 1;
174                    }
175                    return '<span class="nick col-' .
176                            ( $nick_enumerator{$n} % $max_color ) .
177                            '">' . $n . '</span>';
178            },
179    };
180    
181    # POE IRC
182    my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
183            die "can't start ", dump( $irc_config ), ": $!";
184    
185    my $irc = $poe_irc->session_id();
186    _log "IRC session_id $irc";
187    
188  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
189    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
190    
191  my $sql_schema = {  my $sql_schema = {
192          log => '          log => qq{
193  create table log (  create table log (
194          id serial,          id serial,
195          time timestamp default now(),          time timestamp default now(),
# Line 105  create table log ( Line 203  create table log (
203  create index log_time on log(time);  create index log_time on log(time);
204  create index log_channel on log(channel);  create index log_channel on log(channel);
205  create index log_nick on log(nick);  create index log_nick on log(nick);
206          ',          },
207          meta => '          meta => q{
208  create table meta (  create table meta (
209          nick text not null,          nick text not null,
210          channel text not null,          channel text not null,
211          name text not null,          name text not null,
212          value text,          value text,
213          changed timestamp default now(),          changed timestamp default 'now()',
214          primary key(nick,channel,name)          primary key(nick,channel,name)
215  );  );
216          ',          },
217            feeds => qq{
218    create table feeds (
219            id serial,
220            url text not null,
221            name text,
222            delay interval not null default '5 min',
223            active boolean default true,
224            channel text not null,
225            nick text not null,
226            private boolean default false,
227            last_update timestamp default 'now()',
228            polls int default 0,
229            updates int default 0
230    );
231    create unique index feeds_url on feeds(url);
232    insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
233            },
234  };  };
235    
236  foreach my $table ( keys %$sql_schema ) {  foreach my $table ( keys %$sql_schema ) {
# Line 158  sub meta { Line 273  sub meta {
273                  if ( $@ || ! $sth->rows ) {                  if ( $@ || ! $sth->rows ) {
274                          $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });                          $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
275                          $sth->execute( $value, $nick, $channel, $name );                          $sth->execute( $value, $nick, $channel, $name );
276                          _log "created $nick/$channel/$name = $value";                          warn "## created $nick/$channel/$name = $value\n";
277                  } else {                  } else {
278                          _log "updated $nick/$channel/$name = $value ";                          warn "## updated $nick/$channel/$name = $value\n";
279                  }                  }
280    
281                  return $value;                  return $value;
# Line 170  sub meta { Line 285  sub meta {
285                  my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });                  my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
286                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
287                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
288                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
289                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
290                  return $v;                  return $v;
291    
# Line 179  sub meta { Line 294  sub meta {
294    
295    
296    
297  my $sth = $dbh->prepare(qq{  my $sth_insert_log = $dbh->prepare(qq{
298  insert into log  insert into log
299          (channel, me, nick, message, time)          (channel, me, nick, message, time)
300  values (?,?,?,?,?)  values (?,?,?,?,?)
# Line 187  values (?,?,?,?,?) Line 302  values (?,?,?,?,?)
302    
303    
304  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
305    
306  =head2 get_from_log  =head2 get_from_log
307    
# Line 224  C<me>, C<nick> and C<message> keys. Line 338  C<me>, C<nick> and C<message> keys.
338  sub get_from_log {  sub get_from_log {
339          my $args = {@_};          my $args = {@_};
340    
341          $args->{fmt} ||= {          if ( ! $args->{fmt} ) {
342                  date => '[%s] ',                  $args->{fmt} = {
343                  time => '{%s} ',                          date => '[%s] ',
344                  time_channel => '{%s %s} ',                          time => '{%s} ',
345                  nick => '%s: ',                          time_channel => '{%s %s} ',
346                  me_nick => '***%s ',                          nick => '%s: ',
347                  message => '%s',                          me_nick => '***%s ',
348          };                          message => '%s',
349                    };
350            }
351    
352          my $sql_message = qq{          my $sql_message = qq{
353                  select                  select
# Line 254  sub get_from_log { Line 370  sub get_from_log {
370    
371          my $sql = $context ? $sql_context : $sql_message;          my $sql = $context ? $sql_context : $sql_message;
372    
373          $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});          sub check_date {
374          $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });                  my $date = shift || return;
375          $sql .= " where date(time) = ? " if ($args->{date});                  my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
376          $sql .= " order by log.time desc";                  if ( $@ ) {
377          $sql .= " limit " . $args->{limit} if ($args->{limit});                          warn "invalid date $date\n";
378                            $new_date = DateTime->now->ymd;
379                    }
380                    return $new_date;
381            }
382    
383            my @where;
384            my @args;
385            my $msg;
386    
         my $sth = $dbh->prepare( $sql );  
387          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
388                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
389                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
390                  $sth->execute( ( '%' . $search . '%' ) x 2 );                  push @where, 'message ilike ? or nick ilike ?';
391                  _log "search for '$search' returned ", $sth->rows, " results ", $context || '';                  push @args, ( ( '%' . $search . '%' ) x 2 );
392          } elsif (my $tag = $args->{tag}) {                  $msg = "Search for '$search'";
393                  $sth->execute();          }
394                  _log "tag '$tag' returned ", $sth->rows, " results ", $context || '';  
395          } elsif (my $date = $args->{date}) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
396                  $sth->execute($date);                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
397                  _log "found ", $sth->rows, " messages for date $date ", $context || '';                  $msg = "Search for tags $args->{tag}";
         } else {  
                 $sth->execute();  
398          }          }
399    
400            if (my $date = $args->{date} ) {
401                    $date = check_date( $date );
402                    push @where, 'date(time) = ?';
403                    push @args, $date;
404                    $msg = "search for date $date";
405            }
406    
407            $sql .= " where " . join(" and ", @where) if @where;
408    
409            $sql .= " order by log.time desc";
410            $sql .= " limit " . $args->{limit} if ($args->{limit});
411    
412            #warn "### sql: $sql ", dump( @args );
413    
414            my $sth = $dbh->prepare( $sql );
415            eval { $sth->execute( @args ) };
416            return if $@;
417    
418            my $nr_results = $sth->rows;
419    
420          my $last_row = {          my $last_row = {
421                  date => '',                  date => '',
422                  time => '',                  time => '',
# Line 295  sub get_from_log { Line 437  sub get_from_log {
437    
438          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
439    
440          my @msgs = (          $msg .= ' produced ' . (
441                  "Showing " . ($#rows + 1) . " messages..."                  $nr_results == 0 ? 'no results' :
442                    $nr_results == 0 ? 'one result' :
443                            $nr_results . ' results'
444          );          );
445    
446            my @msgs = ( $msg );
447    
448          if ($context) {          if ($context) {
449                  my @ids = @rows;                  my @ids = @rows;
450                  @rows = ();                  @rows = ();
# Line 355  sub get_from_log { Line 501  sub get_from_log {
501  #                       $row->{nick} = $nick;  #                       $row->{nick} = $nick;
502  #               }  #               }
503    
504                    $append = 0 if $row->{me};
505    
506                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
507                          # obfu way to find format for me_nick if needed or fallback to default                          # obfu way to find format for me_nick if needed or fallback to default
508                          my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};                          my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
# Line 395  my $cloud = HTML::TagCloud->new; Line 543  my $cloud = HTML::TagCloud->new;
543    
544  =head2 add_tag  =head2 add_tag
545    
546   add_tag( id => 42, message => 'irc message' );   add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
547    
548  =cut  =cut
549    
550    my @last_tags;
551    
552  sub add_tag {  sub add_tag {
553          my $arg = {@_};          my $arg = {@_};
554    
555          return unless ($arg->{id} && $arg->{message});          return unless ($arg->{id} && $arg->{message});
556    
557          my $m = $arg->{message};          my $m = $arg->{message};
558          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
559            my @tags;
560    
561          while ($m =~ s#$tag_regex##s) {          while ($m =~ s#$tag_regex##s) {
562                  my $tag = $1;                  my $tag = $1;
563                  next if (! $tag || $tag =~ m/https?:/i);                  next if (! $tag || $tag =~ m/https?:/i);
564                  push @{ $tags->{$tag} }, $arg->{id};                  push @{ $tags->{$tag} }, $arg->{id};
565                  #warn "+tag $tag: $arg->{id}\n";                  #warn "+tag $tag: $arg->{id}\n";
566                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
567                    push @tags, $tag;
568    
569            }
570    
571            if ( @tags ) {
572                    pop @last_tags if $#last_tags == $last_x_tags;
573                    unshift @last_tags, { tags => [ @tags ], %$arg };
574          }          }
575    
576  }  }
577    
578  =head2 seed_tags  =head2 seed_tags
# Line 423  Read all tags from database and create i Line 582  Read all tags from database and create i
582  =cut  =cut
583    
584  sub seed_tags {  sub seed_tags {
585          my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });          my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
586          $sth->execute;          $sth->execute;
587          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
588                  add_tag( %$row );                  add_tag( %$row );
589          }          }
590    
591          foreach my $tag (keys %$tags) {          foreach my $tag (keys %$tags) {
592                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
593          }          }
594  }  }
595    
# Line 443  seed_tags; Line 602  seed_tags;
602          channel => '#foobar',          channel => '#foobar',
603          me => 0,          me => 0,
604          nick => 'dpavlin',          nick => 'dpavlin',
605          msg => 'test message',          message => 'test message',
606          time => '2006-06-25 18:57:18',          time => '2006-06-25 18:57:18',
607    );    );
608    
# Line 455  C<me> if not specified will be C<0> (not Line 614  C<me> if not specified will be C<0> (not
614    
615  sub save_message {  sub save_message {
616          my $a = {@_};          my $a = {@_};
617            confess "have msg" if $a->{msg};
618          $a->{me} ||= 0;          $a->{me} ||= 0;
619          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
620    
621          _log          _log "ARCHIVE",
622                  $a->{channel}, " ",                  $a->{channel}, " ",
623                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
624                  " " . $a->{msg};                  " " . $a->{message};
625    
626          from_to($a->{msg}, 'UTF-8', $ENCODING);          $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
627            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
         $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});  
         add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),  
                 message => $a->{msg});  
628  }  }
629    
630    
631  if ($import_dircproxy) {  if ($import_dircproxy) {
632          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
633          warn "importing $import_dircproxy...\n";          warn "importing $import_dircproxy...\n";
634          my $tz_offset = 2 * 60 * 60;    # TZ GMT+2          my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
635          while(<$l>) {          while(<$l>) {
636                  chomp;                  chomp;
637                  if (/^@(\d+)\s(\S+)\s(.+)$/) {                  if (/^@(\d+)\s(\S+)\s(.+)$/) {
# Line 492  if ($import_dircproxy) { Line 649  if ($import_dircproxy) {
649                                  channel => $CHANNEL,                                  channel => $CHANNEL,
650                                  me => $me,                                  me => $me,
651                                  nick => $nick,                                  nick => $nick,
652                                  msg => $msg,                                  message => $msg,
653                                  time => $dt->ymd . " " . $dt->hms,                                  time => $dt->ymd . " " . $dt->hms,
654                          ) if ($nick !~ m/^-/);                          ) if ($nick !~ m/^-/);
655    
# Line 505  if ($import_dircproxy) { Line 662  if ($import_dircproxy) {
662          exit;          exit;
663  }  }
664    
   
665  #  #
666  # POE handing part  # RSS follow
667  #  #
668    
669  my $SKIPPING = 0;               # if skipping, how many we've done  my $_stat;
670  my $SEND_QUEUE;                 # cache  
671  my $ping;                                               # ping stats  POE::Component::Client::HTTP->spawn(
672            Alias   => 'rss-fetch',
673  POE::Component::IRC->new($IRC_ALIAS);          Timeout => 30,
674    );
675  POE::Session->create( inline_states =>  
676     {_start => sub {        =head2 rss_parse_xml
677                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');  
678                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);    rss_parse_xml({
679      },          url => 'http://www.example.com/rss',
680      irc_255 => sub {    # server is done blabbing          send_rss_msgs => 42,
681                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);    });
682                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');  
683                  $_[KERNEL]->yield("heartbeat"); # start heartbeat  =cut
684  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  
685                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  sub rss_parse_xml {
686            my ($args) = @_;
687    
688            warn "## rss_parse_xml ",dump( @_ ) if $debug;
689    
690            # how many messages to send out when feed is seen for the first time?
691            my $send_rss_msgs = $args->{send_rss_msgs};
692            $send_rss_msgs = 1 if ! defined $send_rss_msgs;
693    
694            _log "RSS fetch first $send_rss_msgs items from", $args->{url};
695    
696            my $feed = XML::Feed->parse( \$args->{xml} );
697            if ( ! $feed ) {
698                    _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
699                    return;
700            }
701    
702            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
703    
704            my ( $total, $updates ) = ( 0, 0 );
705            for my $entry ($feed->entries) {
706                    $total++;
707    
708                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
709                    # seen allready?
710                    warn "## $seen_times ",$entry->id if $debug;
711                    next if $seen_times > 0;
712    
713                    sub prefix {
714                            my ($txt,$var) = @_;
715                            $var =~ s/\s+/ /gs;
716                            $var =~ s/^\s+//g;
717                            $var =~ s/\s+$//g;
718                            return $txt . $var if $var;
719                    }
720    
721                    # fix absolute and relative links to feed entries
722                    my $link = $entry->link;
723                    if ( $link =~ m!^/! ) {
724                            my $host = $args->{url};
725                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
726                            $link = "$host/$link";
727                    } elsif ( $link !~ m!^http! ) {
728                            $link = $args->{url} . $link;
729                    }
730    
731                    my $msg;
732                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
733                    $msg .= prefix( ' by ' , $entry->author );
734                    $msg .= prefix( ' | ' , $entry->title );
735                    $msg .= prefix( ' | ' , $link );
736    #               $msg .= prefix( ' id ' , $entry->id );
737                    if ( my $tags = $entry->category ) {
738                            $tags =~ s!^\s+!!;
739                            $tags =~ s!\s*$! !;
740                            $tags =~ s!,?\s+!// !g;
741                            $msg .= prefix( ' ' , $tags );
742                    }
743    
744                    if ( $seen_times == 0 && $send_rss_msgs ) {
745                            $send_rss_msgs--;
746                            if ( ! $args->{private} ) {
747                                    # FIXME bug! should be save_message
748                                    save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
749    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
750                            }
751                            my ( $type, $to ) = ( 'notice', $args->{channel} );
752                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
753    
754                            _log("RSS generated $type to $to:", $msg);
755                            # XXX enqueue message to send later
756                            sub enqueue_post {
757                                    my $post = dump( @_ );
758                                    warn "## queue_post $post\n" if $debug;
759                                    $dq->enqueue_string( $post );
760                            }
761                            enqueue_post( $type => $to => $msg );
762    
763                            $updates++;
764                    }
765            }
766    
767            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
768            $sql .= qq{, updates = updates + $updates } if $updates;
769            $sql .= qq{where id = } . $args->{id};
770            eval { $dbh->do( $sql ) };
771    
772            _log "RSS got $total items of which $updates new from", $args->{url};
773    
774            return $updates;
775    }
776    
777    sub rss_fetch_all {
778            my ( $kernel, $send_rss_msgs )  = @_;
779            warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug;
780            my $sql = qq{
781                    select id, url, name, channel, nick, private
782                    from feeds
783                    where active is true
784            };
785            # limit to newer feeds only if we are not sending messages out
786            $sql .= qq{     and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
787            my $sth = $dbh->prepare( $sql );
788            $sth->execute();
789            warn "# ",$sth->rows," active RSS feeds\n";
790            my $count = 0;
791            while (my $row = $sth->fetchrow_hashref) {
792                    $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs;
793                    $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
794                    $kernel->post(
795                            'rss-fetch',
796                            'request',
797                            'rss_response',
798                            HTTP::Request->new( GET => $row->{url} ),
799                    );
800                    warn "## queued rss-fetch ", dump( $row ) if $debug;
801            }
802            return "OK, scheduled " . $sth->rows . " feeds for refresh";
803    }
804    
805    
806    sub rss_check_updates {
807            my $kernel = shift;
808            $_stat->{rss}->{last_poll} ||= time();
809            my $dt = time() - $_stat->{rss}->{last_poll};
810            if ( $dt > $rss_min_delay ) {
811                    warn "## rss_check_updates $dt > $rss_min_delay\n";
812                    $_stat->{rss}->{last_poll} = time();
813                    _log rss_fetch_all( $kernel );
814            }
815            # XXX send queue messages
816            while ( my $job = $dq->pickup_queued_job() ) {
817                    my $data = read_file( $job->get_data_path ) || die "can't load ", $job->get_data_path, ": $!";
818                    my @data = eval $data;
819                    _log "IRC post from queue:", @data;
820                    $kernel->post( $irc => @data );
821                    $job->finish;
822                    warn "## done queued job: ",dump( @data ) if $debug;
823            }
824    }
825    
826    POE::Session->create( inline_states => {
827            _start => sub {      
828                    $_[KERNEL]->post( $irc => register => 'all' );
829                    $_[KERNEL]->post( $irc => connect => {} );
830      },      },
831            irc_001 => sub {
832                    my ($kernel,$sender) = @_[KERNEL,SENDER];
833                    my $poco_object = $sender->get_heap();
834                    _log "connected to",$poco_object->server_name();
835                    $kernel->post( $sender => join => $_ ) for @channels;
836                    # seen RSS cache, so don't send out messages
837                    _log rss_fetch_all( $kernel, 0 );
838                    undef;
839            },
840    #       irc_255 => sub {        # server is done blabbing
841    #               $_[KERNEL]->post( $irc => join => $CHANNEL);
842    #       },
843      irc_public => sub {      irc_public => sub {
844                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
845                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
846                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
847                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
848    
849                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
850                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
851                    rss_check_updates( $kernel );
852      },      },
853      irc_ctcp_action => sub {      irc_ctcp_action => sub {
854                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 543  POE::Session->create( inline_states => Line 856  POE::Session->create( inline_states =>
856                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
857                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
858    
859                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
860    
861                  if ( my $twitter = ( $nick, $channel, 'twitter' ) ) {                  if ( $use_twitter ) {
862                          _log("FIXME: send twitter for $nick on $channel [$twitter]");                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
863                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
864                                    _log("sending twitter for $nick/$login on $channel ");
865                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
866                                    $bot->update("<${channel}> $msg");
867                            }
868                  }                  }
869    
870      },      },
871          irc_ping => sub {          irc_ping => sub {
872                  warn "pong ", $_[ARG0], $/;                  _log( "pong ", $_[ARG0] );
873                  $ping->{ $_[ARG0] }++;                  $_stat->{ping}->{ $_[ARG0] }++;
874                    rss_check_updates( $_[KERNEL] );
875          },          },
876          irc_invite => sub {          irc_invite => sub {
877                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
878                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
879                  my $channel = $_[ARG1];                  my $channel = $_[ARG1];
880    
881                  warn "invited to $channel by $nick";                  _log "invited to $channel by $nick";
882    
883                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );                  $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
884                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post( $irc => 'join' => $channel );
885    
886          },          },
887          irc_msg => sub {          irc_msg => sub {
# Line 570  POE::Session->create( inline_states => Line 889  POE::Session->create( inline_states =>
889                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
890                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
891                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
892                  from_to($msg, 'UTF-8', $ENCODING);                  warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
893    
894                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
895                  my @out;                  my @out;
# Line 581  POE::Session->create( inline_states => Line 900  POE::Session->create( inline_states =>
900    
901                          $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";                          $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
902    
903                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
904    
905                          _log ">> /msg $1 $2";                          _log ">> /$1 $2 $3";
906                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $irc => $1 => $2, $3 );
907                          $res = '';                          $res = '';
908    
909                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
# Line 593  POE::Session->create( inline_states => Line 912  POE::Session->create( inline_states =>
912    
913                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
914                                  select                                  select
915                                          nick,                                          trim(both '_' from nick) as nick,
916                                          count(*) as count,                                          count(*) as count,
917                                          sum(length(message)) as len                                          sum(length(message)) as len
918                                  from log                                  from log
919                                  group by nick                                  group by trim(both '_' from nick)
920                                  order by len desc,count desc                                  order by len desc,count desc
921                                  limit $nr                                  limit $nr
922                          });                          });
# Line 614  POE::Session->create( inline_states => Line 933  POE::Session->create( inline_states =>
933    
934                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
935                                  _log "last: $res";                                  _log "last: $res";
936                                  from_to($res, $ENCODING, 'UTF-8');                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
937                          }                          }
938    
939                          $res = '';                          $res = '';
# Line 629  POE::Session->create( inline_states => Line 947  POE::Session->create( inline_states =>
947                                          search => $what,                                          search => $what,
948                                  )) {                                  )) {
949                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
950                                  from_to($res, $ENCODING, 'UTF-8');                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
951                          }                          }
952    
953                          $res = '';                          $res = '';
# Line 665  POE::Session->create( inline_states => Line 982  POE::Session->create( inline_states =>
982                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
983                                  " from " . ( join(", ", @nicks) || 'nobody' );                                  " from " . ( join(", ", @nicks) || 'nobody' );
984    
985                          $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );                          $_[KERNEL]->post( $irc => notice => $nick, $res );
986    
987                  } elsif ($msg =~ m/^ping/) {                  } elsif ($msg =~ m/^ping/) {
988                          $res = "ping = " . dump( $ping );                          $res = "ping = " . dump( $_stat->{ping} );
989                  } elsif ($msg =~ m/^(?:twitter)\s+(\S+)\s+(.*?)/) {                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
                         if ( defined( $2 ) ) {  
                                 meta($nick, $channel, 'twitter', "$1\t$2");  
                                 $res = "saved twitter auth for $1 -- /me on $channel will auto-update twitter status";  
                         } else {  
                                 meta($nick, $channel, 'twitter', '' );  
                                 $res = "removed twitter status update for /me on $channel";  
                         }  
                 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size)*\s*(\d*)/) {  
990                          if ( ! defined( $1 ) ) {                          if ( ! defined( $1 ) ) {
991                                  my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });                                  my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
992                                  $sth->execute( $nick, $channel );                                  $sth->execute( $nick, $channel );
993                                  $res = "config for $nick ";                                  $res = "config for $nick on $channel";
994                                  while ( my ($n,$v) = $sth->fetchrow_array ) {                                  while ( my ($n,$v) = $sth->fetchrow_array ) {
995                                          $res .= "| $n = $v";                                          $res .= " | $n = $v";
996                                  }                                  }
997                          } elsif ( defined( $2 ) ) {                          } elsif ( ! $2 ) {
                                 meta( $nick, $channel, $1, $2 );  
                                 $res = "saved $1 = $2";  
                         } else {  
998                                  my $val = meta( $nick, $channel, $1 );                                  my $val = meta( $nick, $channel, $1 );
999                                  $res = "current $1 = " . ( $val ? $val : 'undefined' );                                  $res = "current $1 = " . ( $val ? $val : 'undefined' );
1000                            } else {
1001                                    my $validate = {
1002                                            'last-size' => qr/^\d+/,
1003                                            'twitter' => qr/^\w+\s+\w+/,
1004                                    };
1005    
1006                                    my ( $op, $val ) = ( $1, $2 );
1007    
1008                                    if ( my $regex = $validate->{$op} ) {
1009                                            if ( $val =~ $regex ) {
1010                                                    meta( $nick, $channel, $op, $val );
1011                                                    $res = "saved $op = $val";
1012                                            } else {
1013                                                    $res = "config option $op = $val doesn't validate against $regex";
1014                                            }
1015                                    } else {
1016                                            $res = "config option $op doesn't exist";
1017                                    }
1018                            }
1019                    } elsif ($msg =~ m/^rss-update/) {
1020                            $res = rss_fetch_all( $_[KERNEL] );
1021                    } elsif ($msg =~ m/^rss-list/) {
1022                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
1023                            $sth->execute;
1024                            while (my @row = $sth->fetchrow_array) {
1025                                    $_[KERNEL]->post( $irc => privmsg => $nick, join(' | ',@row) );
1026                          }                          }
1027                            $res = '';
1028                    } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
1029                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
1030    
1031                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
1032                            $channel = $nick if $sub eq 'private';
1033    
1034                            my $sql = {
1035                                    add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
1036    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
1037                                    start   => qq{ update feeds set active = true   where url = ? },
1038                                    stop    => qq{ update feeds set active = false  where url = ? },
1039                                    clean   => qq{ update feeds set last_update = now() - delay where url = ? },
1040                            };
1041    
1042                            if ( $command eq 'add' && ! $channel ) {
1043                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
1044                            } elsif (my $q = $sql->{$command} ) {
1045                                    my $sth = $dbh->prepare( $q );
1046                                    my @data = ( $url );
1047                                    if ( $command eq 'add' ) {
1048                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
1049                                    }
1050                                    warn "## $command SQL $q with ",dump( @data ),"\n";
1051                                    eval { $sth->execute( @data ) };
1052                                    if ($@) {
1053                                            $res = "ERROR: $@";
1054                                    } else {
1055                                            $res = "OK, RSS executed $command " . ( $sub ? "-$sub" : '' ) ."on $channel url $url";
1056                                            if ( $command eq 'clean' ) {
1057                                                    my $seen = $_stat->{rss}->{seen} || die "no seen?";
1058                                                    my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
1059                                                    foreach my $c ( keys %$seen ) {
1060                                                            my $c_hash = $seen->{$c} || die "no seen->{$c}";
1061                                                            die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
1062                                                            foreach my $link ( keys %$c_hash ) {
1063                                                                    next unless $link eq $want_link;
1064                                                                    _log "RSS removed seen $c $url $link";
1065                                                            }
1066                                                    }
1067                                            }
1068                                    }
1069                            } else {
1070                                    $res = "ERROR: don't know what to do with: $msg";
1071                            }
1072                    } elsif ($msg =~ m/^rss-clean/) {
1073                            # this makes sense because we didn't catch rss-clean http://... before!
1074                            $_stat->{rss} = undef;
1075                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
1076                            $res = "OK, cleaned RSS cache";
1077                  }                  }
1078    
1079                  if ($res) {                  if ($res) {
1080                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
1081                          from_to($res, $ENCODING, 'UTF-8');                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                         $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
1082                  }                  }
1083    
1084                    rss_check_updates( $_[KERNEL] );
1085            },
1086            irc_372 => sub {
1087                    _log "<< motd",$_[ARG0],$_[ARG1];
1088          },          },
1089            irc_375 => sub {
1090                    _log "<< motd", $_[ARG0], "start";
1091            },
1092            irc_376 => sub {
1093                    _log "<< motd", $_[ARG0], "end";
1094            },
1095    #       irc_433 => sub {
1096    #               print "# irc_433: ",$_[ARG1], "\n";
1097    #               warn "## indetify $NICK\n";
1098    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1099    #       },
1100    #       irc_451 # please register
1101          irc_477 => sub {          irc_477 => sub {
1102                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
1103                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> IDENTIFY $NICK";
1104                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1105          },          },
1106          irc_505 => sub {          irc_505 => sub {
1107                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
1108                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> register $NICK";
1109  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );                  $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1110  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1111    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1112    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1113          },          },
1114          irc_registered => sub {          irc_registered => sub {
1115                  _log "## registrated $NICK";                  _log "<< registered $NICK";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1116          },          },
1117          irc_disconnected => sub {          irc_disconnected => sub {
1118                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1119                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1120                    $_[KERNEL]->post( $irc => connect => {} );
1121          },          },
1122          irc_socketerr => sub {          irc_socketerr => sub {
1123                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1124                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1125                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
1126            },
1127            irc_notice => sub {
1128                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1129                    my $m = $_[ARG2];
1130                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1131                            _log ">> suggested to $1 $2";
1132                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1133                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1134                            _log ">> registreted, so IDENTIFY";
1135                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1136                    } else {
1137                            warn "## ignore $m\n" if $debug;
1138                    }
1139            },
1140            irc_snotice => sub {
1141                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1142                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1143                            warn ">> $1 | $2\n";
1144                            $_[KERNEL]->post( $irc => lc($1) => $2);
1145                    }
1146          },          },
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
1147      _child => sub {},      _child => sub {},
1148      _default => sub {      _default => sub {
1149                  _log sprintf "sID:%s %s %s",                  _log sprintf "sID:%s %s %s",
# Line 738  POE::Session->create( inline_states => Line 1153  POE::Session->create( inline_states =>
1153                          "";                          "";
1154        0;                        # false for signals        0;                        # false for signals
1155      },      },
1156      my_add => sub {          rss_response => sub {
1157        my $trailing = $_[ARG0];                  my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1158        my $session = $_[SESSION];                  my $request_object  = $request_packet->[0];
1159        POE::Session->create                  my $response_object = $response_packet->[0];
1160            (inline_states =>  
1161             {_start => sub {                  my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1162                $_[HEAP]->{wheel} =                  if ( $row ) {
1163                  POE::Wheel::FollowTail->new                          $row->{xml} = $response_object->content;
1164                      (                          rss_parse_xml( $row );
1165                       Filename => $FOLLOWS{$trailing},                  } else {
1166                       InputEvent => 'got_line',                          warn "## can't find rss->fetch for ", $request_object->uri;
1167                      );                  }
1168              },          },
             got_line => sub {  
               $_[KERNEL]->post($session => my_tailed =>  
                                time, $trailing, $_[ARG0]);  
             },  
            },  
           );  
       
     },  
     my_tailed => sub {  
       my ($time, $file, $line) = @_[ARG0..ARG2];  
       ## $time will be undef on a probe, or a time value if a real line  
   
       ## PoCo::IRC has throttling built in, but no external visibility  
       ## so this is reaching "under the hood"  
       $SEND_QUEUE ||=  
         $_[KERNEL]->alias_resolve($IRC_ALIAS)->get_heap->{send_queue};  
   
       ## handle "no need to keep skipping" transition  
       if ($SKIPPING and @$SEND_QUEUE < 1) {  
         $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                          "[discarded $SKIPPING messages]");  
         $SKIPPING = 0;  
       }  
   
       ## handle potential message display  
       if ($time) {  
         if ($SKIPPING or @$SEND_QUEUE > 3) { # 3 msgs per 10 seconds  
           $SKIPPING++;  
         } else {  
           my @time = localtime $time;  
           $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                            sprintf "%02d:%02d:%02d: %s: %s",  
                            ($time[2] + 11) % 12 + 1, $time[1], $time[0],  
                            $file, $line);  
         }  
       }  
   
       ## handle re-probe/flush if skipping  
       if ($SKIPPING) {  
         $_[KERNEL]->delay($_[STATE] => 0.5); # $time will be undef  
       }  
   
     },  
     my_heartbeat => sub {  
       $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep");  
       $_[KERNEL]->delay($_[STATE] => 10);  
     }  
1169     },     },
1170    );    );
1171    
1172  # http server  # http server
1173    
1174    _log "WEB archive at $url";
1175    
1176  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1177          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1178            PreHandler => {
1179                    '/' => sub {
1180                            $_[0]->header(Connection => 'close')
1181                    }
1182            },
1183          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1184          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1185  );  );
1186    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1187  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1188  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1189  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 819  p { margin: 0; padding: 0.1em; } Line 1191  p { margin: 0; padding: 0.1em; }
1191  .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }  .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1192  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1193  .search { float: right; }  .search { float: right; }
1194    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1195    a:hover.tag { border: 1px solid #eee }
1196    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1197    /*
1198  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1199  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1200  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1201  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1202  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1203  a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }  */
1204  a:hover.tag { border: 1px solid #eee }  .calendar { border: 1px solid red; width: 100%; }
1205  hr { border: 1px dashed #ccc; height: 1px; clear: both; }  .month { border: 0px; width: 100%; }
1206  _END_OF_STYLE_  _END_OF_STYLE_
1207    
1208  my $max_color = 4;  $max_color = 0;
1209    
1210  my %nick_enumerator;  my @cols = qw(
1211            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1212            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1213            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1214            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1215            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1216    );
1217    
1218    foreach my $c (@cols) {
1219            $style .= ".col-${max_color} { background: $c }\n";
1220            $max_color++;
1221    }
1222    _log "WEB defined $max_color colors for users...";
1223    
1224  sub root_handler {  sub root_handler {
1225          my ($request, $response) = @_;          my ($request, $response) = @_;
1226          $response->code(RC_OK);          $response->code(RC_OK);
1227          $response->content_type("text/html; charset=$ENCODING");  
1228            # this doesn't seem to work, so moved to PreHandler
1229            #$response->header(Connection => 'close');
1230    
1231            return RC_OK if $request->uri =~ m/favicon.ico$/;
1232    
1233          my $q;          my $q;
1234    
# Line 849  sub root_handler { Line 1241  sub root_handler {
1241          }          }
1242    
1243          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1244            my $r_url = $request->url;
1245    
1246            my @commands = qw( tags last-tag follow stat );
1247            my $commands_re = join('|',@commands);
1248    
1249            if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1250                    my $show = lc($1);
1251                    my $nr = $2;
1252    
1253                    my $type = 'RSS';       # Atom
1254    
1255                    $response->content_type( 'application/' . lc($type) . '+xml' );
1256    
1257                    my $html = '<!-- error -->';
1258                    #warn "create $type feed from ",dump( @last_tags );
1259    
1260                    my $feed = XML::Feed->new( $type );
1261                    $feed->link( $url );
1262    
1263                    my $rc = RC_OK;
1264    
1265                    if ( $show eq 'tags' ) {
1266                            $nr ||= 50;
1267                            $feed->title( "tags from $CHANNEL" );
1268                            $feed->link( "$url/tags" );
1269                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1270                            my $feed_entry = XML::Feed::Entry->new($type);
1271                            $feed_entry->title( "$nr tags from $CHANNEL" );
1272                            $feed_entry->author( $NICK );
1273                            $feed_entry->link( '/#tags'  );
1274    
1275                            $feed_entry->content(
1276                                    qq{<![CDATA[<style type="text/css">}
1277                                    . $cloud->css
1278                                    . qq{</style>}
1279                                    . $cloud->html( $nr )
1280                                    . qq{]]>}
1281                            );
1282                            $feed->add_entry( $feed_entry );
1283    
1284                    } elsif ( $show eq 'last-tag' ) {
1285    
1286                            $nr ||= $last_x_tags;
1287                            $nr = $last_x_tags if $nr > $last_x_tags;
1288    
1289                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1290                            $feed->description( "collects messages which have tags// in them" );
1291    
1292                            foreach my $m ( @last_tags ) {
1293    #                               warn dump( $m );
1294                                    #my $tags = join(' ', @{$m->{tags}} );
1295                                    my $feed_entry = XML::Feed::Entry->new($type);
1296                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1297                                    $feed_entry->author( $m->{nick} );
1298                                    $feed_entry->link( '/#' . $m->{id}  );
1299                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1300    
1301                                    my $message = $filter->{message}->( $m->{message} );
1302                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1303    #                               warn "## message = $message\n";
1304    
1305                                    #$feed_entry->summary(
1306                                    $feed_entry->content(
1307                                            "<![CDATA[$message]]>"
1308                                    );
1309                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1310                                    $feed->add_entry( $feed_entry );
1311    
1312                                    $nr--;
1313                                    last if $nr <= 0;
1314    
1315                            }
1316    
1317                    } elsif ( $show =~ m/^follow/ ) {
1318    
1319                            $feed->title( "Feeds which this bot follows" );
1320    
1321                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1322                            $sth->execute;
1323                            while (my $row = $sth->fetchrow_hashref) {
1324                                    my $feed_entry = XML::Feed::Entry->new($type);
1325                                    $feed_entry->title( $row->{name} );
1326                                    $feed_entry->link( $row->{url}  );
1327                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1328                                    $feed_entry->content(
1329                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1330                                    );
1331                                    $feed->add_entry( $feed_entry );
1332                            }
1333    
1334                    } elsif ( $show =~ m/^stat/ ) {
1335    
1336                            my $feed_entry = XML::Feed::Entry->new($type);
1337                            $feed_entry->title( "Internal stats" );
1338                            $feed_entry->content(
1339                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1340                            );
1341                            $feed->add_entry( $feed_entry );
1342    
1343                    } else {
1344                            _log "WEB unknown rss request $r_url";
1345                            $feed->title( "unknown $r_url" );
1346                            foreach my $c ( @commands ) {
1347                                    my $feed_entry = XML::Feed::Entry->new($type);
1348                                    $feed_entry->title( "rss/$c" );
1349                                    $feed_entry->link( "$url/rss/$c" );
1350                                    $feed->add_entry( $feed_entry );
1351                            }
1352                            $rc = RC_DENY;
1353                    }
1354    
1355                    $response->content( $feed->as_xml );
1356                    return $rc;
1357            }
1358    
1359            if ( $@ ) {
1360                    warn "$@";
1361            }
1362    
1363            $response->content_type("text/html; charset=UTF-8");
1364    
1365          my $html =          my $html =
1366                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1367                  $cloud->css .                  . $cloud->css
1368                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1369                  qq{                  . qq{
1370                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1371                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1372                  <input type="submit" value="search">                  <input type="submit" value="search">
1373                  </form>                  </form>
1374                  } .                  }
1375                  $cloud->html(500) .                  . $cloud->html(500)
1376                  qq{<p>};                  . qq{<p>};
1377          if ($request->url =~ m#/history#) {  
1378            if ($request->url =~ m#/tags?#) {
1379                    # nop
1380            } elsif ($request->url =~ m#/history#) {
1381                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1382                          select date(time) as date,count(*) as nr                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1383                                  from log                                  from log
1384                                  group by date(time)                                  group by date(time)
1385                                  order by date(time) desc                                  order by date(time) desc
1386                  });                  });
1387                  $sth->execute();                  $sth->execute();
1388                  my ($l_yyyy,$l_mm) = (0,0);                  my ($l_yyyy,$l_mm) = (0,0);
1389                    $html .= qq{<table class="calendar"><tr>};
1390                  my $cal;                  my $cal;
1391                    my $ord = 0;
1392                  while (my $row = $sth->fetchrow_hashref) {                  while (my $row = $sth->fetchrow_hashref) {
1393                          # this is probably PostgreSQL specific, expects ISO date                          # this is probably PostgreSQL specific, expects ISO date
1394                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1395                          if ($yyyy != $l_yyyy || $mm != $l_mm) {                          if ($yyyy != $l_yyyy || $mm != $l_mm) {
1396                                  $html .= $cal->as_HTML() if ($cal);                                  if ( $cal ) {
1397                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1398                                            $ord++;
1399                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1400                                    }
1401                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1402                                  $cal->border(2);                                  $cal->border(1);
1403                                    $cal->width('30%');
1404                                    $cal->cellheight('5em');
1405                                    $cal->tableclass('month');
1406                                    #$cal->cellclass('day');
1407                                    $cal->sunday('SUN');
1408                                    $cal->saturday('SAT');
1409                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1410                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1411                          }                          }
1412                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1413                                  <a href="/?date=$row->{date}">$row->{nr}</a>                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1414                          });                          ]) if $cal;
1415                            
1416                  }                  }
1417                  $html .= $cal->as_HTML() if ($cal);                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1418    
1419          } else {          } else {
1420                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1421                          get_from_log(                          get_from_log(
1422                                  limit => $q->param('last') || $q->param('date') ? undef : 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1423                                  search => $search || undef,                                  search => $search || undef,
1424                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1425                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
1426                                  fmt => {                                  fmt => {
1427                                          date => sub {                                          date => sub {
1428                                                  my $date = shift || return;                                                  my $date = shift || return;
1429                                                  qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div>};                                                  qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1430                                          },                                          },
1431                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1432                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 905  sub root_handler { Line 1434  sub root_handler {
1434                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1435                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1436                                  },                                  },
1437                                  filter => {                                  filter => $filter,
                                         message => sub {  
                                                 my $m = shift || return;  
                                                 $m =~ s/($escape_re)/$escape{$1}/gs;  
                                                 $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;  
                                                 $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;  
                                                 return $m;  
                                         },  
                                         nick => sub {  
                                                 my $n = shift || return;  
                                                 if (! $nick_enumerator{$n})  {  
                                                         my $max = scalar keys %nick_enumerator;  
                                                         $nick_enumerator{$n} = $max + 1;  
                                                 }  
                                                 return '<span class="nick col-' .  
                                                         ( $nick_enumerator{$n} % $max_color ) .  
                                                         '">' . $n . '</span>';  
                                         },  
                                 },  
1438                          )                          )
1439                  );                  );
1440          }          }
# Line 933  sub root_handler { Line 1444  sub root_handler {
1444          <p>See <a href="/history">history</a> of all messages.</p>          <p>See <a href="/history">history</a> of all messages.</p>
1445          </body></html>};          </body></html>};
1446    
1447          $response->content( $html );          $response->content( decode('utf-8',$html) );
1448            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1449          return RC_OK;          return RC_OK;
1450  }  }
1451    
Legend:
Removed from v.50  
changed lines
  Added in v.125
  ViewVC Help
Powered by ViewVC 1.1.26