/[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

trunk/irc-logger.pl revision 37 by dpavlin, Sun Jun 25 17:40:59 2006 UTC trunk/bin/irc-logger.pl revision 123 by dpavlin, Fri Mar 14 14:45:04 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 18  irc-logger.pl Line 38  irc-logger.pl
38    
39  Import log from C<dircproxy> to C<irc-logger> database  Import log from C<dircproxy> to C<irc-logger> database
40    
41    =item --log=irc-logger.log
42    
43    =back
44    
45  =head1 DESCRIPTION  =head1 DESCRIPTION
46    
47  log all conversation on irc channel  log all conversation on irc channel
# Line 26  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  ## END CONFIG  my $sleep_on_error = 5;
94    
95    # 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  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
102  use HTTP::Status;  
103  use DBI;  my $url = "http://$HOSTNAME:$http_port";
104  use Encode qw/from_to is_utf8/;  
105  use Regexp::Common qw /URI/;  ## END CONFIG
106  use CGI::Simple;  
107  use HTML::TagCloud;  my $use_twitter = 1;
108  use POSIX qw/strftime/;  eval { require Net::Twitter; };
109  use HTML::CalendarMonthSimple;  $use_twitter = 0 if ($@);
 use Getopt::Long;  
 use DateTime;  
110    
111  my $import_dircproxy;  my $import_dircproxy;
112    my $log_path;
113  GetOptions(  GetOptions(
114          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
115            'log:s' => \$log_path,
116            'queue:s' => \$queue_dir,
117            'debug!' => \$debug,
118  );  );
119    
120  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  #$SIG{__DIE__} = sub {
121    #       confess "fatal error";
122    #};
123    
124    sub _log {
125            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  eval {                  $m =~ s/($escape_re)/$escape{$1}/gs;
160          $dbh->do(qq{ select count(*) from log });                  $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  if ($@) {  # POE IRC
182          warn "creating database table in $DSN\n";  my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
183          $dbh->do(<<'_SQL_SCHEMA_');          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;
189    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
190    
191    my $sql_schema = {
192            log => qq{
193  create table log (  create table log (
194          id serial,          id serial,
195          time timestamp default now(),          time timestamp default now(),
# Line 94  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 => q{
208    create table meta (
209            nick text not null,
210            channel text not null,
211            name text not null,
212            value text,
213            changed timestamp default 'now()',
214            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  _SQL_SCHEMA_  foreach my $table ( keys %$sql_schema ) {
237    
238            eval {
239                    $dbh->do(qq{ select count(*) from $table });
240            };
241    
242            if ($@) {
243                    warn "creating database table $table in $DSN\n";
244                    $dbh->do( $sql_schema->{ $table } );
245            }
246    }
247    
248    
249    =head2 meta
250    
251    Set or get some meta data into database
252    
253            meta('nick','channel','var_name', $var_value );
254    
255            $var_value = meta('nick','channel','var_name');
256            ( $var_value, $changed ) = meta('nick','channel','var_name');
257    
258    =cut
259    
260    sub meta {
261            my ($nick,$channel,$name,$value) = @_;
262    
263            # normalize channel name
264            $channel =~ s/^#//;
265    
266            if (defined($value)) {
267    
268                    my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
269    
270                    eval { $sth->execute( $value, $nick, $channel, $name ) };
271    
272                    # error or no result
273                    if ( $@ || ! $sth->rows ) {
274                            $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
275                            $sth->execute( $value, $nick, $channel, $name );
276                            warn "## created $nick/$channel/$name = $value\n";
277                    } else {
278                            warn "## updated $nick/$channel/$name = $value\n";
279                    }
280    
281                    return $value;
282    
283            } else {
284    
285                    my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
286                    $sth->execute( $nick, $channel, $name );
287                    my ($v,$c) = $sth->fetchrow_array;
288                    warn "## fetched $nick/$channel/$name = $v [$c]\n";
289                    return ($v,$c) if wantarray;
290                    return $v;
291    
292            }
293  }  }
294    
295  my $sth = $dbh->prepare(qq{  
296    
297    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 (?,?,?,?,?)
301  });  });
302    
303    
304  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
305    
306  =head2 get_from_log  =head2 get_from_log
307    
# Line 126  my $tag_regex = '\b([\w-_]+)//'; Line 322  my $tag_regex = '\b([\w-_]+)//';
322                  }                  }
323          },          },
324          context => 5,          context => 5,
325            full_rows => 1,
326   );   );
327    
328  Order is important. Fields are first passed through C<filter> (if available) and  Order is important. Fields are first passed through C<filter> (if available) and
# Line 133  then throgh C<< sprintf($fmt->{message}, Line 330  then throgh C<< sprintf($fmt->{message},
330    
331  C<context> defines number of messages around each search hit for display.  C<context> defines number of messages around each search hit for display.
332    
333    C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
334    C<me>, C<nick> and C<message> keys.
335    
336  =cut  =cut
337    
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 168  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                  warn "search for '$search' returned ", $sth->rows, " results ", $context || '', "\n";                  push @args, ( ( '%' . $search . '%' ) x 2 );
392          } elsif (my $tag = $args->{tag}) {                  $msg = "Search for '$search'";
                 $sth->execute();  
                 warn "tag '$tag' returned ", $sth->rows, " results ", $context || '', "\n";  
         } elsif (my $date = $args->{date}) {  
                 $sth->execute($date);  
                 warn "found ", $sth->rows, " messages for date $date ", $context || '', "\n";  
         } else {  
                 $sth->execute();  
393          }          }
394    
395            if ($args->{tag} && $tags->{ $args->{tag} }) {
396                    push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
397                    $msg = "Search for tags $args->{tag}";
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 202  sub get_from_log { Line 430  sub get_from_log {
430                  unshift @rows, $row;                  unshift @rows, $row;
431          }          }
432    
433          my @msgs = (          # normalize nick names
434                  "Showing " . ($#rows + 1) . " messages..."          map {
435                    $_->{nick} =~ s/^_*(.*?)_*$/$1/
436            } @rows;
437    
438            return @rows if ($args->{full_rows});
439    
440            $msg .= ' produced ' . (
441                    $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 258  sub get_from_log { Line 497  sub get_from_log {
497                  my $append = 1;                  my $append = 1;
498    
499                  my $nick = $row->{nick};                  my $nick = $row->{nick};
500                  if ($nick =~ s/^_*(.*?)_*$/$1/) {  #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
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
# Line 302  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 330  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 350  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 362  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());
620    
621          print          _log
                 $a->{time} ? $a->{time} . " " : strftime($TIMESTAMP,localtime()),  
622                  $a->{channel}, " ",                  $a->{channel}, " ",
623                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
624                  " " . $a->{msg} . "\n";                  " " . $a->{message};
   
         from_to($a->{msg}, 'UTF-8', $ENCODING);  
625    
626          $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});          $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),          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
                 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 398  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    
656                  } else {                  } else {
657                          warn "can't parse: $_\n";                          _log "can't parse: $_";
658                  }                  }
659          }          }
660          close($l);          close($l);
# Line 411  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;
 my $SEND_QUEUE;                 # cache  
670    
671  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::Client::HTTP->spawn(
672            Alias   => 'rss-fetch',
673            Timeout => 30,
674    );
675    
676  POE::Session->create( inline_states =>  sub rss_parse_xml {
677     {_start => sub {                my ($args) = @_;
678                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');  
679                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);          warn "## rss_parse_xml ",dump( @_ ) if $debug;
680      },  
681      irc_255 => sub {    # server is done blabbing          # how many messages to send out when feed is seen for the first time?
682                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);          my $send_rss_msgs = 1;
683                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');  
684                  $_[KERNEL]->yield("heartbeat"); # start heartbeat          _log "RSS fetch", $args->{url};
685  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  
686                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );          my $feed = XML::Feed->parse( \$args->{xml} );
687            if ( ! $feed ) {
688                    _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
689                    return;
690            }
691    
692            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
693    
694            my ( $total, $updates ) = ( 0, 0 );
695            for my $entry ($feed->entries) {
696                    $total++;
697    
698                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
699                    # seen allready?
700                    warn "## $seen_times ",$entry->id if $debug;
701                    next if $seen_times > 0;
702    
703                    sub prefix {
704                            my ($txt,$var) = @_;
705                            $var =~ s/\s+/ /gs;
706                            $var =~ s/^\s+//g;
707                            $var =~ s/\s+$//g;
708                            return $txt . $var if $var;
709                    }
710    
711                    # fix absolute and relative links to feed entries
712                    my $link = $entry->link;
713                    if ( $link =~ m!^/! ) {
714                            my $host = $args->{url};
715                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
716                            $link = "$host/$link";
717                    } elsif ( $link !~ m!^http! ) {
718                            $link = $args->{url} . $link;
719                    }
720    
721                    my $msg;
722                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
723                    $msg .= prefix( ' by ' , $entry->author );
724                    $msg .= prefix( ' | ' , $entry->title );
725                    $msg .= prefix( ' | ' , $link );
726    #               $msg .= prefix( ' id ' , $entry->id );
727                    if ( my $tags = $entry->category ) {
728                            $tags =~ s!^\s+!!;
729                            $tags =~ s!\s*$! !;
730                            $tags =~ s!,?\s+!// !g;
731                            $msg .= prefix( ' ' , $tags );
732                    }
733    
734                    if ( $seen_times == 0 && $send_rss_msgs ) {
735                            $send_rss_msgs--;
736                            if ( ! $args->{private} ) {
737                                    # FIXME bug! should be save_message
738                                    save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
739    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
740                            }
741                            my ( $type, $to ) = ( 'notice', $args->{channel} );
742                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
743    
744                            _log("RSS generated $type to $to:", $msg);
745                            # XXX enqueue message to send later
746                            sub enqueue_post {
747                                    my $post = dump( @_ );
748                                    warn "## queue_post $post\n" if $debug;
749                                    $dq->enqueue_string( $post );
750                            }
751                            enqueue_post( $type => $to => $msg );
752    
753                            $updates++;
754                    }
755            }
756    
757            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
758            $sql .= qq{, updates = updates + $updates } if $updates;
759            $sql .= qq{where id = } . $args->{id};
760            eval { $dbh->do( $sql ) };
761    
762            _log "RSS got $total items of which $updates new";
763    
764            return $updates;
765    }
766    
767    sub rss_fetch_all {
768            my $kernel = shift;
769            my $sql = qq{
770                    select id, url, name, channel, nick, private
771                    from feeds
772                    where active is true
773            };
774            # limit to newer feeds only if we are not sending messages out
775            $sql .= qq{     and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
776            my $sth = $dbh->prepare( $sql );
777            $sth->execute();
778            warn "# ",$sth->rows," active RSS feeds\n";
779            my $count = 0;
780            while (my $row = $sth->fetchrow_hashref) {
781                    warn "## queued rss-fetch for ", $row->{url} if $debug;
782                    $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
783                    $kernel->post(
784                            'rss-fetch',
785                            'request',
786                            'rss_response',
787                            HTTP::Request->new( GET => $row->{url} ),
788                    );
789            }
790            return "OK, scheduled " . $sth->rows . " feeds for refresh";
791    }
792    
793    
794    sub rss_check_updates {
795            my $kernel = shift;
796            $_stat->{rss}->{last_poll} ||= time();
797            my $dt = time() - $_stat->{rss}->{last_poll};
798            if ( $dt > $rss_min_delay ) {
799                    warn "## rss_check_updates $dt > $rss_min_delay\n";
800                    $_stat->{rss}->{last_poll} = time();
801                    _log rss_fetch_all( $kernel );
802            }
803            # XXX send queue messages
804            while ( my $job = $dq->pickup_queued_job() ) {
805                    my $data = read_file( $job->get_data_path ) || die "can't load ", $job->get_data_path, ": $!";
806    #               $kernel->post( $irc => $type => $to, $msg );
807                    my @data = eval $data;
808                    _log "IRC post from queue:", @data;
809                    $kernel->post( $irc => @data );
810                    $job->finish;
811                    warn "## done queued job: ",dump( @data ) if $debug;
812            }
813    }
814    
815    POE::Session->create( inline_states => {
816            _start => sub {      
817                    $_[KERNEL]->post( $irc => register => 'all' );
818                    $_[KERNEL]->post( $irc => connect => {} );
819      },      },
820            irc_001 => sub {
821                    my ($kernel,$sender) = @_[KERNEL,SENDER];
822                    my $poco_object = $sender->get_heap();
823                    _log "connected to",$poco_object->server_name();
824                    $kernel->post( $sender => join => $_ ) for @channels;
825                    # seen RSS cache
826                    _log rss_fetch_all( $kernel );
827                    undef;
828            },
829    #       irc_255 => sub {        # server is done blabbing
830    #               $_[KERNEL]->post( $irc => join => $CHANNEL);
831    #       },
832      irc_public => sub {      irc_public => sub {
833                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
834                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
835                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
836                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
837    
838                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
839                    meta( $nick, $channel, 'last-msg', $msg );
840                    rss_check_updates( $kernel );
841      },      },
842      irc_ctcp_action => sub {      irc_ctcp_action => sub {
843                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 447  POE::Session->create( inline_states => Line 845  POE::Session->create( inline_states =>
845                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
846                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
847    
848                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
849    
850                    if ( $use_twitter ) {
851                            if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
852                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
853                                    _log("sending twitter for $nick/$login on $channel ");
854                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
855                                    $bot->update("<${channel}> $msg");
856                            }
857                    }
858    
859      },      },
860            irc_ping => sub {
861                    _log( "pong ", $_[ARG0] );
862                    $_stat->{ping}->{ $_[ARG0] }++;
863                    rss_check_updates( $_[KERNEL] );
864            },
865            irc_invite => sub {
866                    my $kernel = $_[KERNEL];
867                    my $nick = (split /!/, $_[ARG0])[0];
868                    my $channel = $_[ARG1];
869    
870                    _log "invited to $channel by $nick";
871    
872                    $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
873                    $_[KERNEL]->post( $irc => 'join' => $channel );
874    
875            },
876          irc_msg => sub {          irc_msg => sub {
877                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
878                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
879                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
880                  from_to($msg, 'UTF-8', $ENCODING);                  my $channel = $_[ARG1]->[0];
881                    warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
882    
883                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
884                  my @out;                  my @out;
885    
886                  print "<< $msg\n";                  _log "<< $msg";
887    
888                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
889    
890                          $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";
891    
892                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
893    
894                          print ">> /msg $1 $2\n";                          _log ">> /$1 $2 $3";
895                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $irc => $1 => $2, $3 );
896                          $res = '';                          $res = '';
897    
898                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
# Line 475  POE::Session->create( inline_states => Line 900  POE::Session->create( inline_states =>
900                          my $nr = $1 || 10;                          my $nr = $1 || 10;
901    
902                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
903                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
904                                            trim(both '_' from nick) as nick,
905                                            count(*) as count,
906                                            sum(length(message)) as len
907                                    from log
908                                    group by trim(both '_' from nick)
909                                    order by len desc,count desc
910                                    limit $nr
911                          });                          });
912                          $sth->execute();                          $sth->execute();
913                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
914                          my @users;                          my @users;
915                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
916                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
917                          }                          }
918                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
919                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
920    
921                          foreach my $res (get_from_log( limit => $1 )) {                          my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
922                                  print "last: $res\n";  
923                                  from_to($res, $ENCODING, 'UTF-8');                          foreach my $res (get_from_log( limit => $limit )) {
924                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  _log "last: $res";
925                                    $_[KERNEL]->post( $irc => privmsg => $nick, $res );
926                          }                          }
927    
928                          $res = '';                          $res = '';
# Line 502  POE::Session->create( inline_states => Line 935  POE::Session->create( inline_states =>
935                                          limit => 20,                                          limit => 20,
936                                          search => $what,                                          search => $what,
937                                  )) {                                  )) {
938                                  print "search [$what]: $res\n";                                  _log "search [$what]: $res";
939                                  from_to($res, $ENCODING, 'UTF-8');                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
940                          }                          }
941    
942                          $res = '';                          $res = '';
943    
944                    } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
945    
946                            my ($what,$limit) = ($1,$2);
947                            $limit ||= 100;
948    
949                            my $stat;
950    
951                            foreach my $res (get_from_log(
952                                            limit => $limit,
953                                            search => $what,
954                                            full_rows => 1,
955                                    )) {
956                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
957                                            $stat->{vote}->{$1}++;
958                                            $stat->{from}->{ $res->{nick} }++;
959                                    }
960                            }
961    
962                            my @nicks;
963                            foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
964                                    push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
965                                            "(" . $stat->{from}->{$nick} . ")"
966                                    );
967                            }
968    
969                            $res =
970                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
971                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
972                                    " from " . ( join(", ", @nicks) || 'nobody' );
973    
974                            $_[KERNEL]->post( $irc => notice => $nick, $res );
975    
976                    } elsif ($msg =~ m/^ping/) {
977                            $res = "ping = " . dump( $_stat->{ping} );
978                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
979                            if ( ! defined( $1 ) ) {
980                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
981                                    $sth->execute( $nick, $channel );
982                                    $res = "config for $nick on $channel";
983                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
984                                            $res .= " | $n = $v";
985                                    }
986                            } elsif ( ! $2 ) {
987                                    my $val = meta( $nick, $channel, $1 );
988                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
989                            } else {
990                                    my $validate = {
991                                            'last-size' => qr/^\d+/,
992                                            'twitter' => qr/^\w+\s+\w+/,
993                                    };
994    
995                                    my ( $op, $val ) = ( $1, $2 );
996    
997                                    if ( my $regex = $validate->{$op} ) {
998                                            if ( $val =~ $regex ) {
999                                                    meta( $nick, $channel, $op, $val );
1000                                                    $res = "saved $op = $val";
1001                                            } else {
1002                                                    $res = "config option $op = $val doesn't validate against $regex";
1003                                            }
1004                                    } else {
1005                                            $res = "config option $op doesn't exist";
1006                                    }
1007                            }
1008                    } elsif ($msg =~ m/^rss-update/) {
1009                            $res = rss_fetch_all( $_[KERNEL] );
1010                    } elsif ($msg =~ m/^rss-list/) {
1011                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
1012                            $sth->execute;
1013                            while (my @row = $sth->fetchrow_array) {
1014                                    $_[KERNEL]->post( $irc => privmsg => $nick, join(' | ',@row) );
1015                            }
1016                            $res = '';
1017                    } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
1018                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
1019    
1020                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
1021                            $channel = $nick if $sub eq 'private';
1022    
1023                            my $sql = {
1024                                    add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
1025    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
1026                                    start   => qq{ update feeds set active = true   where url = ? },
1027                                    stop    => qq{ update feeds set active = false  where url = ? },
1028                                    clean   => qq{ update feeds set last_update = now() - delay where url = ? },
1029                            };
1030    
1031                            if ( $command eq 'add' && ! $channel ) {
1032                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
1033                            } elsif (my $q = $sql->{$command} ) {
1034                                    my $sth = $dbh->prepare( $q );
1035                                    my @data = ( $url );
1036                                    if ( $command eq 'add' ) {
1037                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
1038                                    }
1039                                    warn "## $command SQL $q with ",dump( @data ),"\n";
1040                                    eval { $sth->execute( @data ) };
1041                                    if ($@) {
1042                                            $res = "ERROR: $@";
1043                                    } else {
1044                                            $res = "OK, RSS executed $command " . ( $sub ? "-$sub" : '' ) ."on $channel url $url";
1045                                            if ( $command eq 'clean' ) {
1046                                                    my $seen = $_stat->{rss}->{seen} || die "no seen?";
1047                                                    my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
1048                                                    foreach my $c ( keys %$seen ) {
1049                                                            my $c_hash = $seen->{$c} || die "no seen->{$c}";
1050                                                            die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
1051                                                            foreach my $link ( keys %$c_hash ) {
1052                                                                    next unless $link eq $want_link;
1053                                                                    _log "RSS removed seen $c $url $link";
1054                                                            }
1055                                                    }
1056                                            }
1057                                    }
1058                            } else {
1059                                    $res = "ERROR: don't know what to do with: $msg";
1060                            }
1061                    } elsif ($msg =~ m/^rss-clean/) {
1062                            # this makes sense because we didn't catch rss-clean http://... before!
1063                            $_stat->{rss} = undef;
1064                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
1065                            $res = "OK, cleaned RSS cache";
1066                  }                  }
1067    
1068                  if ($res) {                  if ($res) {
1069                          print ">> [$nick] $res\n";                          _log ">> [$nick] $res";
1070                          from_to($res, $ENCODING, 'UTF-8');                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                         $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
1071                  }                  }
1072    
1073                    rss_check_updates( $_[KERNEL] );
1074          },          },
1075          irc_477 => sub {          irc_372 => sub {
1076                  print "# irc_477: ",$_[ARG1], "\n";                  _log "<< motd",$_[ARG0],$_[ARG1];
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );  
1077          },          },
1078          irc_505 => sub {          irc_375 => sub {
1079                  print "# irc_505: ",$_[ARG1], "\n";                  _log "<< motd", $_[ARG0], "start";
                 $_[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" );  
1080          },          },
1081          irc_registered => sub {          irc_376 => sub {
1082                  warn "## indetify $NICK\n";                  _log "<< motd", $_[ARG0], "end";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1083          },          },
1084  #       irc_433 => sub {  #       irc_433 => sub {
1085  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
1086  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
1087  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1088  #       },  #       },
1089    #       irc_451 # please register
1090            irc_477 => sub {
1091                    _log "<< irc_477: ",$_[ARG1];
1092                    _log ">> IDENTIFY $NICK";
1093                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1094            },
1095            irc_505 => sub {
1096                    _log "<< irc_505: ",$_[ARG1];
1097                    _log ">> register $NICK";
1098                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1099    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1100    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1101    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1102            },
1103            irc_registered => sub {
1104                    _log "<< registered $NICK";
1105            },
1106            irc_disconnected => sub {
1107                    _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1108                    sleep($sleep_on_error);
1109                    $_[KERNEL]->post( $irc => connect => {} );
1110            },
1111            irc_socketerr => sub {
1112                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1113                    sleep($sleep_on_error);
1114                    $_[KERNEL]->post( $irc => connect => {} );
1115            },
1116            irc_notice => sub {
1117                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1118                    my $m = $_[ARG2];
1119                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1120                            _log ">> suggested to $1 $2";
1121                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1122                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1123                            _log ">> registreted, so IDENTIFY";
1124                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1125                    } else {
1126                            warn "## ignore $m\n" if $debug;
1127                    }
1128            },
1129            irc_snotice => sub {
1130                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1131                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1132                            warn ">> $1 | $2\n";
1133                            $_[KERNEL]->post( $irc => lc($1) => $2);
1134                    }
1135            },
1136      _child => sub {},      _child => sub {},
1137      _default => sub {      _default => sub {
1138                  printf "%s #%s %s %s\n",                  _log sprintf "sID:%s %s %s",
1139                          strftime($TIMESTAMP,localtime()), $_[SESSION]->ID, $_[ARG0],                          $_[SESSION]->ID, $_[ARG0],
1140                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
1141                          $_[ARG1]                                        ?       $_[ARG1]                                        :                          $_[ARG1]                                        ?       $_[ARG1]                                        :
1142                          "";                          "";
1143        0;                        # false for signals        0;                        # false for signals
1144      },      },
1145      my_add => sub {          rss_response => sub {
1146        my $trailing = $_[ARG0];                  my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1147        my $session = $_[SESSION];                  my $request_object  = $request_packet->[0];
1148        POE::Session->create                  my $response_object = $response_packet->[0];
1149            (inline_states =>  
1150             {_start => sub {                  my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1151                $_[HEAP]->{wheel} =                  if ( $row ) {
1152                  POE::Wheel::FollowTail->new                          $row->{xml} = $response_object->content;
1153                      (                          rss_parse_xml( $row );
1154                       Filename => $FOLLOWS{$trailing},                  } else {
1155                       InputEvent => 'got_line',                          warn "## can't find rss->fetch for ", $request_object->uri;
1156                      );                  }
1157              },          },
             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);  
     }  
1158     },     },
1159    );    );
1160    
1161  # http server  # http server
1162    
1163    _log "WEB archive at $url";
1164    
1165  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1166          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1167            PreHandler => {
1168                    '/' => sub {
1169                            $_[0]->header(Connection => 'close')
1170                    }
1171            },
1172          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1173          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1174  );  );
1175    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1176  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1177  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1178  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 627  p { margin: 0; padding: 0.1em; } Line 1180  p { margin: 0; padding: 0.1em; }
1180  .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 ; }
1181  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1182  .search { float: right; }  .search { float: right; }
1183    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1184    a:hover.tag { border: 1px solid #eee }
1185    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1186    /*
1187  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1188  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1189  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1190  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1191  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1192  a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }  */
1193  a:hover.tag { border: 1px solid #eee }  .calendar { border: 1px solid red; width: 100%; }
1194  hr { border: 1px dashed #ccc; height: 1px; clear: both; }  .month { border: 0px; width: 100%; }
1195  _END_OF_STYLE_  _END_OF_STYLE_
1196    
1197  my $max_color = 4;  $max_color = 0;
1198    
1199  my %nick_enumerator;  my @cols = qw(
1200            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1201            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1202            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1203            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1204            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1205    );
1206    
1207    foreach my $c (@cols) {
1208            $style .= ".col-${max_color} { background: $c }\n";
1209            $max_color++;
1210    }
1211    _log "WEB defined $max_color colors for users...";
1212    
1213  sub root_handler {  sub root_handler {
1214          my ($request, $response) = @_;          my ($request, $response) = @_;
1215          $response->code(RC_OK);          $response->code(RC_OK);
1216          $response->content_type("text/html; charset=$ENCODING");  
1217            # this doesn't seem to work, so moved to PreHandler
1218            #$response->header(Connection => 'close');
1219    
1220            return RC_OK if $request->uri =~ m/favicon.ico$/;
1221    
1222          my $q;          my $q;
1223    
# Line 657  sub root_handler { Line 1230  sub root_handler {
1230          }          }
1231    
1232          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1233            my $r_url = $request->url;
1234    
1235            my @commands = qw( tags last-tag follow stat );
1236            my $commands_re = join('|',@commands);
1237    
1238            if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1239                    my $show = lc($1);
1240                    my $nr = $2;
1241    
1242                    my $type = 'RSS';       # Atom
1243    
1244                    $response->content_type( 'application/' . lc($type) . '+xml' );
1245    
1246                    my $html = '<!-- error -->';
1247                    #warn "create $type feed from ",dump( @last_tags );
1248    
1249                    my $feed = XML::Feed->new( $type );
1250                    $feed->link( $url );
1251    
1252                    my $rc = RC_OK;
1253    
1254                    if ( $show eq 'tags' ) {
1255                            $nr ||= 50;
1256                            $feed->title( "tags from $CHANNEL" );
1257                            $feed->link( "$url/tags" );
1258                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1259                            my $feed_entry = XML::Feed::Entry->new($type);
1260                            $feed_entry->title( "$nr tags from $CHANNEL" );
1261                            $feed_entry->author( $NICK );
1262                            $feed_entry->link( '/#tags'  );
1263    
1264                            $feed_entry->content(
1265                                    qq{<![CDATA[<style type="text/css">}
1266                                    . $cloud->css
1267                                    . qq{</style>}
1268                                    . $cloud->html( $nr )
1269                                    . qq{]]>}
1270                            );
1271                            $feed->add_entry( $feed_entry );
1272    
1273                    } elsif ( $show eq 'last-tag' ) {
1274    
1275                            $nr ||= $last_x_tags;
1276                            $nr = $last_x_tags if $nr > $last_x_tags;
1277    
1278                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1279                            $feed->description( "collects messages which have tags// in them" );
1280    
1281                            foreach my $m ( @last_tags ) {
1282    #                               warn dump( $m );
1283                                    #my $tags = join(' ', @{$m->{tags}} );
1284                                    my $feed_entry = XML::Feed::Entry->new($type);
1285                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1286                                    $feed_entry->author( $m->{nick} );
1287                                    $feed_entry->link( '/#' . $m->{id}  );
1288                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1289    
1290                                    my $message = $filter->{message}->( $m->{message} );
1291                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1292    #                               warn "## message = $message\n";
1293    
1294                                    #$feed_entry->summary(
1295                                    $feed_entry->content(
1296                                            "<![CDATA[$message]]>"
1297                                    );
1298                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1299                                    $feed->add_entry( $feed_entry );
1300    
1301                                    $nr--;
1302                                    last if $nr <= 0;
1303    
1304                            }
1305    
1306                    } elsif ( $show =~ m/^follow/ ) {
1307    
1308                            $feed->title( "Feeds which this bot follows" );
1309    
1310                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1311                            $sth->execute;
1312                            while (my $row = $sth->fetchrow_hashref) {
1313                                    my $feed_entry = XML::Feed::Entry->new($type);
1314                                    $feed_entry->title( $row->{name} );
1315                                    $feed_entry->link( $row->{url}  );
1316                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1317                                    $feed_entry->content(
1318                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1319                                    );
1320                                    $feed->add_entry( $feed_entry );
1321                            }
1322    
1323                    } elsif ( $show =~ m/^stat/ ) {
1324    
1325                            my $feed_entry = XML::Feed::Entry->new($type);
1326                            $feed_entry->title( "Internal stats" );
1327                            $feed_entry->content(
1328                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1329                            );
1330                            $feed->add_entry( $feed_entry );
1331    
1332                    } else {
1333                            _log "WEB unknown rss request $r_url";
1334                            $feed->title( "unknown $r_url" );
1335                            foreach my $c ( @commands ) {
1336                                    my $feed_entry = XML::Feed::Entry->new($type);
1337                                    $feed_entry->title( "rss/$c" );
1338                                    $feed_entry->link( "$url/rss/$c" );
1339                                    $feed->add_entry( $feed_entry );
1340                            }
1341                            $rc = RC_DENY;
1342                    }
1343    
1344                    $response->content( $feed->as_xml );
1345                    return $rc;
1346            }
1347    
1348            if ( $@ ) {
1349                    warn "$@";
1350            }
1351    
1352            $response->content_type("text/html; charset=UTF-8");
1353    
1354          my $html =          my $html =
1355                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1356                  $cloud->css .                  . $cloud->css
1357                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1358                  qq{                  . qq{
1359                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1360                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1361                  <input type="submit" value="search">                  <input type="submit" value="search">
1362                  </form>                  </form>
1363                  } .                  }
1364                  $cloud->html(500) .                  . $cloud->html(500)
1365                  qq{<p>};                  . qq{<p>};
1366          if ($request->url =~ m#/history#) {  
1367            if ($request->url =~ m#/tags?#) {
1368                    # nop
1369            } elsif ($request->url =~ m#/history#) {
1370                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1371                          select date(time) as date,count(*) as nr                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1372                                  from log                                  from log
1373                                  group by date(time)                                  group by date(time)
1374                                  order by date(time) desc                                  order by date(time) desc
1375                  });                  });
1376                  $sth->execute();                  $sth->execute();
1377                  my ($l_yyyy,$l_mm) = (0,0);                  my ($l_yyyy,$l_mm) = (0,0);
1378                    $html .= qq{<table class="calendar"><tr>};
1379                  my $cal;                  my $cal;
1380                    my $ord = 0;
1381                  while (my $row = $sth->fetchrow_hashref) {                  while (my $row = $sth->fetchrow_hashref) {
1382                          # this is probably PostgreSQL specific, expects ISO date                          # this is probably PostgreSQL specific, expects ISO date
1383                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1384                          if ($yyyy != $l_yyyy || $mm != $l_mm) {                          if ($yyyy != $l_yyyy || $mm != $l_mm) {
1385                                  $html .= $cal->as_HTML() if ($cal);                                  if ( $cal ) {
1386                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1387                                            $ord++;
1388                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1389                                    }
1390                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1391                                  $cal->border(2);                                  $cal->border(1);
1392                                    $cal->width('30%');
1393                                    $cal->cellheight('5em');
1394                                    $cal->tableclass('month');
1395                                    #$cal->cellclass('day');
1396                                    $cal->sunday('SUN');
1397                                    $cal->saturday('SAT');
1398                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1399                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1400                          }                          }
1401                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1402                                  <a href="/?date=$row->{date}">$row->{nr}</a>                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1403                          });                          ]) if $cal;
1404                            
1405                  }                  }
1406                  $html .= $cal->as_HTML() if ($cal);                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1407    
1408          } else {          } else {
1409                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1410                          get_from_log(                          get_from_log(
1411                                  limit => $q->param('last') || $q->param('date') ? undef : 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1412                                  search => $search || undef,                                  search => $search || undef,
1413                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1414                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
1415                                  fmt => {                                  fmt => {
1416                                          date => sub {                                          date => sub {
1417                                                  my $date = shift || return;                                                  my $date = shift || return;
1418                                                  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>};
1419                                          },                                          },
1420                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1421                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 713  sub root_handler { Line 1423  sub root_handler {
1423                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1424                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1425                                  },                                  },
1426                                  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>';  
                                         },  
                                 },  
1427                          )                          )
1428                  );                  );
1429          }          }
# Line 741  sub root_handler { Line 1433  sub root_handler {
1433          <p>See <a href="/history">history</a> of all messages.</p>          <p>See <a href="/history">history</a> of all messages.</p>
1434          </body></html>};          </body></html>};
1435    
1436          $response->content( $html );          $response->content( decode('utf-8',$html) );
1437            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1438          return RC_OK;          return RC_OK;
1439  }  }
1440    
Legend:
Removed from v.37  
changed lines
  Added in v.123
  ViewVC Help
Powered by ViewVC 1.1.26