/[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 36 by dpavlin, Sun Jun 25 16:37:39 2006 UTC trunk/bin/irc-logger.pl revision 150 by dpavlin, Sat Oct 8 18:43:21 2011 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 POSIX qw/strftime/;
11    use HTML::CalendarMonthSimple;
12    use Getopt::Long;
13    use DateTime;
14    use URI::Escape;
15    use Data::Dump qw/dump/;
16    use DateTime::Format::ISO8601;
17    use Carp qw/confess/;
18    use XML::Feed;
19    use DateTime::Format::Flexible;
20    use Encode;
21    #use Redis 2.0;
22    
23  =head1 NAME  =head1 NAME
24    
25  irc-logger.pl  irc-logger.pl
# Line 10  irc-logger.pl Line 28  irc-logger.pl
28    
29  ./irc-logger.pl  ./irc-logger.pl
30    
31    =head2 Options
32    
33    =over 4
34    
35    =item --import-dircproxy=filename
36    
37    Import log from C<dircproxy> to C<irc-logger> database
38    
39    =item --log=irc-logger.log
40    
41    =back
42    
43  =head1 DESCRIPTION  =head1 DESCRIPTION
44    
45  log all conversation on irc channel  log all conversation on irc channel
# Line 18  log all conversation on irc channel Line 48  log all conversation on irc channel
48    
49  ## CONFIG  ## CONFIG
50    
51  my $HOSTNAME = `hostname`;  my $debug = 0;
52    
53    my $irc_config = {
54            nick => 'irc-logger',
55            server => 'irc.freenode.net',
56            port => 6667,
57            ircname => 'Anna the bot: try /msg irc-logger help',
58    };
59    
60    my $HOSTNAME = `hostname -f`;
61    chomp($HOSTNAME);
62    
63    
 my $NICK = 'irc-logger';  
 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  
 my $CONNECT =  
   {Server => 'irc.freenode.net',  
    Nick => $NICK,  
    Ircname => "try /msg $NICK help",  
   };  
64  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
 $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  
 my $IRC_ALIAS = "log";  
65    
66  my %FOLLOWS =  if ( $HOSTNAME =~ m/llin/ ) {
67    (          $irc_config->{nick} = 'irc-logger-llin';
68     ACCESS => "/var/log/apache/access.log",  #       $irc_config = {
69     ERROR => "/var/log/apache/error.log",  #               nick => 'irc-logger-llin',
70    );  #               server => 'localhost',
71    #               port => 6668,
72    #       };
73            $CHANNEL = '#irc-logger';
74    } elsif ( $HOSTNAME =~ m/lugarin/ ) {
75            $irc_config->{server} = 'irc.carnet.hr';
76            $CHANNEL = '#riss';
77    }
78    
79    my @channels = ( $CHANNEL );
80    
81    warn "## config = ", dump( $irc_config ) if $debug;
82    
83    my $NICK = $irc_config->{nick} or die "no nick?";
84    
85  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
86    
 my $ENCODING = 'ISO-8859-2';  
87  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
88    
89    my $sleep_on_error = 5;
90    
91    # number of last tags to keep in circular buffer
92    my $last_x_tags = 50;
93    
94    # don't pull rss feeds more often than this
95    my $rss_min_delay = 60;
96    
97    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
98    
99    my $url = "http://$HOSTNAME:$http_port";
100    
101  ## END CONFIG  ## END CONFIG
102    
103    my $use_twitter = 1;
104    eval { require Net::Twitter; };
105    $use_twitter = 0 if ($@);
106    
107    my $import_dircproxy;
108    my $log_path;
109    GetOptions(
110            'import-dircproxy:s' => \$import_dircproxy,
111            'log:s' => \$log_path,
112            'debug!' => \$debug,
113    );
114    
115    #$SIG{__DIE__} = sub {
116    #       confess "fatal error";
117    #};
118    
119  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  sub _log {
120  use HTTP::Status;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
121  use DBI;  }
122  use Encode qw/from_to is_utf8/;  
123  use Regexp::Common qw /URI/;  open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
 use CGI::Simple;  
 use HTML::TagCloud;  
 use POSIX qw/strftime/;  
 use HTML::CalendarMonthSimple;  
124    
 my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  
125    
126  eval {  # HTML formatters
127          $dbh->do(qq{ select count(*) from log });  
128    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
129    my $escape_re  = join '|' => keys %escape;
130    
131    my $tag_regex = '\b([\w\-_]+)//';
132    
133    my %nick_enumerator;
134    my $max_color = 0;
135    
136    my $filter = {
137            message => sub {
138                    my $m = shift || return;
139    
140                    # protect HTML from wiki modifications
141                    sub e {
142                            my $t = shift;
143                            eval { $t = 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}'; };
144                            return $t;
145                    }
146    
147                    $m =~ s/($escape_re)/$escape{$1}/gs;
148                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
149    #               $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
150                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
151                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
152                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
153    
154                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
155                    return $m;
156            },
157            nick => sub {
158                    my $n = shift || return;
159                    if (! $nick_enumerator{$n})  {
160                            my $max = scalar keys %nick_enumerator;
161                            $nick_enumerator{$n} = $max + 1;
162                    }
163                    return '<span class="nick col-' .
164                            ( $nick_enumerator{$n} % $max_color ) .
165                            '">' . $n . '</span>';
166            },
167  };  };
168    
169  if ($@) {  # POE IRC
170          warn "creating database table in $DSN\n";  my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
171          $dbh->do(<<'_SQL_SCHEMA_');          die "can't start ", dump( $irc_config ), ": $!";
172    
173    my $irc = $poe_irc->session_id();
174    _log "IRC session_id $irc";
175    
176    my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
177    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
178    
179    my $sql_schema = {
180            log => qq{
181  create table log (  create table log (
182          id serial,          id serial,
183          time timestamp default now(),          time timestamp default now(),
# Line 79  create table log ( Line 191  create table log (
191  create index log_time on log(time);  create index log_time on log(time);
192  create index log_channel on log(channel);  create index log_channel on log(channel);
193  create index log_nick on log(nick);  create index log_nick on log(nick);
194            },
195            meta => q{
196    create table meta (
197            nick text not null,
198            channel text not null,
199            name text not null,
200            value text,
201            changed timestamp default 'now()',
202            primary key(nick,channel,name)
203    );
204            },
205            feeds => qq{
206    create table feeds (
207            id serial,
208            url text not null,
209            name text,
210            delay interval not null default '5 min',
211            active boolean default true,
212            channel text not null,
213            nick text not null,
214            private boolean default false,
215            last_update timestamp default 'now()',
216            polls int default 0,
217            updates int default 0
218    );
219    create unique index feeds_url on feeds(url);
220    insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
221            },
222    };
223    
224    foreach my $table ( keys %$sql_schema ) {
225    
226            eval {
227                    $dbh->do(qq{ select count(*) from $table });
228            };
229    
230            if ($@) {
231                    warn "creating database table $table in $DSN\n";
232                    $dbh->do( $sql_schema->{ $table } );
233            }
234    }
235    
236    
237    =head2 meta
238    
239    Set or get some meta data into database
240    
241            meta('nick','channel','var_name', $var_value );
242    
243            $var_value = meta('nick','channel','var_name');
244            ( $var_value, $changed ) = meta('nick','channel','var_name');
245    
246    =cut
247    
248    sub meta {
249            my ($nick,$channel,$name,$value) = @_;
250    
251            # normalize channel name
252            $channel =~ s/^#//;
253    
254            if (defined($value)) {
255    
256  _SQL_SCHEMA_                  my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
257    
258                    eval { $sth->execute( $value, $nick, $channel, $name ) };
259    
260                    if ( $@ ) {
261                            # error
262                            _log("META ERROR: $@");
263                    } elsif ( ! $sth->rows ) {
264                            # no result -> add new
265                            $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
266                            eval { $sth->execute( $value, $nick, $channel, $name ); };
267                            if ( $@ ) {
268                                    _log "META ERROR: $@";
269                            } else {
270                                    _log "META: created $nick/$channel/$name = $value\n";
271                            }
272                    } else {
273                            _log "META: updated $nick/$channel/$name = $value\n";
274                    }
275    
276                    return $value;
277    
278            } else {
279    
280                    my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
281                    $sth->execute( $nick, $channel, $name );
282                    my ($v,$c) = $sth->fetchrow_array;
283                    warn "## fetched $nick/$channel/$name = $v [$c]\n";
284                    return ($v,$c) if wantarray;
285                    return $v;
286    
287            }
288  }  }
289    
290  my $sth = $dbh->prepare(qq{  
291    
292    my $sth_insert_log = $dbh->prepare(qq{
293  insert into log  insert into log
294          (channel, me, nick, message)          (channel, me, nick, message, time)
295  values (?,?,?,?)  values (?,?,?,?,?)
296  });  });
297    
298    
299  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
300    
301  =head2 get_from_log  =head2 get_from_log
302    
# Line 111  my $tag_regex = '\b([\w-_]+)//'; Line 317  my $tag_regex = '\b([\w-_]+)//';
317                  }                  }
318          },          },
319          context => 5,          context => 5,
320            full_rows => 1,
321   );   );
322    
323  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 118  then throgh C<< sprintf($fmt->{message}, Line 325  then throgh C<< sprintf($fmt->{message},
325    
326  C<context> defines number of messages around each search hit for display.  C<context> defines number of messages around each search hit for display.
327    
328    C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
329    C<me>, C<nick> and C<message> keys.
330    
331  =cut  =cut
332    
333  sub get_from_log {  sub get_from_log {
334          my $args = {@_};          my $args = {@_};
335    
336          $args->{fmt} ||= {          if ( ! $args->{fmt} ) {
337                  date => '[%s] ',                  $args->{fmt} = {
338                  time => '{%s} ',                          date => '[%s] ',
339                  time_channel => '{%s %s} ',                          time => '{%s} ',
340                  nick => '%s: ',                          time_channel => '{%s %s} ',
341                  me_nick => '***%s ',                          nick => '%s: ',
342                  message => '%s',                          me_nick => '***%s ',
343          };                          message => '%s',
344                    };
345            }
346    
347          my $sql_message = qq{          my $sql_message = qq{
348                  select                  select
# Line 153  sub get_from_log { Line 365  sub get_from_log {
365    
366          my $sql = $context ? $sql_context : $sql_message;          my $sql = $context ? $sql_context : $sql_message;
367    
368          $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});          sub check_date {
369          $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });                  my $date = shift || return;
370          $sql .= " where date(time) = ? " if ($args->{date});                  my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
371          $sql .= " order by log.time desc";                  if ( $@ ) {
372          $sql .= " limit " . $args->{limit} if ($args->{limit});                          warn "invalid date $date\n";
373                            $new_date = DateTime->now->ymd;
374                    }
375                    return $new_date;
376            }
377    
378            my @where;
379            my @args;
380            my $msg;
381    
         my $sth = $dbh->prepare( $sql );  
382          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
383                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
384                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
385                  $sth->execute( ( '%' . $search . '%' ) x 2 );                  push @where, 'message ilike ? or nick ilike ?';
386                  warn "search for '$search' returned ", $sth->rows, " results ", $context || '', "\n";                  push @args, ( ( '%' . $search . '%' ) x 2 );
387          } elsif (my $tag = $args->{tag}) {                  $msg = "Search for '$search'";
388                  $sth->execute();          }
389                  warn "tag '$tag' returned ", $sth->rows, " results ", $context || '', "\n";  
390          } elsif (my $date = $args->{date}) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
391                  $sth->execute($date);                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
392                  warn "found ", $sth->rows, " messages for date $date ", $context || '', "\n";                  $msg = "Search for tags $args->{tag}";
         } else {  
                 $sth->execute();  
393          }          }
394    
395            if (my $date = $args->{date} ) {
396                    $date = check_date( $date );
397                    push @where, 'date(time) = ?';
398                    push @args, $date;
399                    $msg = "search for date $date";
400            }
401    
402            $sql .= " where " . join(" and ", @where) if @where;
403    
404            $sql .= " order by log.time desc";
405            $sql .= " limit " . $args->{limit} if ($args->{limit});
406    
407            #warn "### sql: $sql ", dump( @args );
408    
409            my $sth = $dbh->prepare( $sql );
410            eval { $sth->execute( @args ) };
411            return if $@;
412    
413            my $nr_results = $sth->rows;
414    
415          my $last_row = {          my $last_row = {
416                  date => '',                  date => '',
417                  time => '',                  time => '',
# Line 187  sub get_from_log { Line 425  sub get_from_log {
425                  unshift @rows, $row;                  unshift @rows, $row;
426          }          }
427    
428          my @msgs = (          # normalize nick names
429                  "Showing " . ($#rows + 1) . " messages..."          map {
430                    $_->{nick} =~ s/^_*(.*?)_*$/$1/
431            } @rows;
432    
433            return @rows if ($args->{full_rows});
434    
435            $msg .= ' produced ' . (
436                    $nr_results == 0 ? 'no results' :
437                    $nr_results == 0 ? 'one result' :
438                            $nr_results . ' results'
439          );          );
440    
441            my @msgs = ( $msg );
442    
443          if ($context) {          if ($context) {
444                  my @ids = @rows;                  my @ids = @rows;
445                  @rows = ();                  @rows = ();
# Line 243  sub get_from_log { Line 492  sub get_from_log {
492                  my $append = 1;                  my $append = 1;
493    
494                  my $nick = $row->{nick};                  my $nick = $row->{nick};
495                  if ($nick =~ s/^_*(.*?)_*$/$1/) {  #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
496                          $row->{nick} = $nick;  #                       $row->{nick} = $nick;
497                  }  #               }
498    
499                    $append = 0 if $row->{me};
500    
501                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
502                          # 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 281  sub get_from_log { Line 532  sub get_from_log {
532          return @msgs;          return @msgs;
533  }  }
534    
535    # tags support
536    
537  my $SKIPPING = 0;               # if skipping, how many we've done  my $cloud = TagCloud->new;
538  my $SEND_QUEUE;                 # cache  $cloud->seed_tags;
   
 POE::Component::IRC->new($IRC_ALIAS);  
539    
540  =head2 save_message  =head2 save_message
541    
542    save_message($channel,$me,$nick,$msg);    save_message(
543            channel => '#foobar',
544            me => 0,
545            nick => 'dpavlin',
546            message => 'test message',
547            time => '2006-06-25 18:57:18',
548      );
549    
550    C<time> is optional, it will use C<< now() >> if it's not available.
551    
552    C<me> if not specified will be C<0> (not C</me> message)
553    
554  =cut  =cut
555    
556  sub save_message {  sub save_message {
557          my ($channel,$me,$nick,$msg) = @_;          my $a = {@_};
558          $me ||= 0;          confess "have msg" if $a->{msg};
559          $sth->execute($channel, $me, $nick, $msg);          $a->{me} ||= 0;
560          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),          $a->{time} ||= strftime($TIMESTAMP,localtime());
561                  message => $msg);  
562            _log "ARCHIVE",
563                    $a->{channel}, " ",
564                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
565                    " " . $a->{message};
566    
567            eval { $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time}); };
568    
569            eval {
570            my @channel = ( 'channel' , $a->{channel}, $a->{nick} );
571            push @channel, 'me' if $a->{me};
572    #       my $redis = Redis->new( server => '192.168.1.61:6379' );
573    #       $redis->publish( join(' ',@channel), $a->{message} );
574            };
575    
576            if ( $@ ) {
577                    _log "ERROR: can't archive ", $a->{message};
578            } else {
579                    $cloud->add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
580            }
581  }  }
582    
 POE::Session->create( inline_states =>  
    {_start => sub {        
                 $_[KERNEL]->post($IRC_ALIAS => register => 'all');  
                 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);  
     },  
     irc_255 => sub {    # server is done blabbing  
                 $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);  
                 $_[KERNEL]->post($IRC_ALIAS => join => '#logger');  
                 $_[KERNEL]->yield("heartbeat"); # start heartbeat  
 #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
     },  
     irc_public => sub {  
                 my $kernel = $_[KERNEL];  
                 my $nick = (split /!/, $_[ARG0])[0];  
                 my $channel = $_[ARG1]->[0];  
                 my $msg = $_[ARG2];  
583    
584                  from_to($msg, 'UTF-8', $ENCODING);  if ($import_dircproxy) {
585            my ( $from_time, $date_time ) = $dbh->selectrow_array(qq{
586                    select date_part('epoch',max(time)),max(time) from log
587            });
588    
589            warn "IMPORT $date_time [$from_time]\n";
590    
591            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
592            warn "importing $import_dircproxy...\n";
593            my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
594            while(<$l>) {
595                    chomp;
596                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
597                            my ($time, $nick, $msg) = ($1,$2,$3);
598    
599                            next if $time <= $from_time;
600    
601                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
602    
603                            my $me = 0;
604                            $me = 1 if ($nick =~ m/^\[\S+]/);
605                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
606    
607                            $msg =~ s/^ACTION\s+// if ($me);
608    
609                            save_message(
610                                    channel => $CHANNEL,
611                                    me => $me,
612                                    nick => $nick,
613                                    message => $msg,
614                                    time => $dt->ymd . " " . $dt->hms,
615                            ) if ($nick !~ m/^-/);
616    
617                  print "$channel: <$nick> $msg\n";                  } else {
618                  save_message($channel, 0, $nick, $msg);                          _log "can't parse: $_";
619      },                  }
620      irc_ctcp_action => sub {          }
621                  my $kernel = $_[KERNEL];          close($l);
622                  my $nick = (split /!/, $_[ARG0])[0];          warn "import over\n";
623                  my $channel = $_[ARG1]->[0];          exit;
624                  my $msg = $_[ARG2];  }
625    
626                  from_to($msg, 'UTF-8', $ENCODING);  #
627    # RSS follow
628    #
629    
630    my $_stat;
631    
632    POE::Component::Client::HTTP->spawn(
633            Alias   => 'rss-fetch',
634            Timeout => 30,
635    );
636    
637                  print "$channel ***$nick $msg\n";  =head2 rss_parse_xml
638                  save_message($channel, 1, $nick, $msg);  
639      },    rss_parse_xml({
640          irc_msg => sub {          url => 'http://www.example.com/rss',
641                  my $kernel = $_[KERNEL];          send_rss_msgs => 42,
642                  my $nick = (split /!/, $_[ARG0])[0];    });
                 my $msg = $_[ARG2];  
                 from_to($msg, 'UTF-8', $ENCODING);  
643    
644                  my $res = "unknown command '$msg', try /msg $NICK help!";  =cut
                 my @out;  
645    
646                  print "<< $msg\n";  sub rss_parse_xml {
647            my ($kernel,$args) = @_;
648    
649                  if ($msg =~ m/^help/i) {          warn "## rss_parse_xml ",dump( $args ) if $debug;
650    
651                          $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";          # how many messages to send out when feed is seen for the first time?
652            my $send_rss_msgs = $args->{send_rss_msgs};
653            $send_rss_msgs = 1 if ! defined $send_rss_msgs;
654    
655            warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug;
656    
657            my $feed;
658            eval { $feed = XML::Feed->parse( \$args->{xml} ) };
659            if ( ! $feed ) {
660                    _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
661                    return;
662            }
663    
664                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {          $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
665    
666                          print ">> /msg $1 $2\n";          my ( $total, $updates ) = ( 0, 0 );
667                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );          for my $entry ($feed->entries) {
668                          $res = '';                  $total++;
669    
670                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
671                    # seen allready?
672                    warn "## $seen_times ",$entry->id if $debug;
673                    next if $seen_times > 0;
674    
675                    sub prefix {
676                            my ($txt,$var) = @_;
677                            $var =~ s/\s+/ /gs;
678                            $var =~ s/^\s+//g;
679                            $var =~ s/\s+$//g;
680                            return $txt . $var if $var;
681                    }
682    
683                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  # fix absolute and relative links to feed entries
684                    my $link = $entry->link;
685                    if ( $link =~ m!^/! ) {
686                            my $host = $args->{url};
687                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
688                            $link = "$host/$link";
689                    } elsif ( $link !~ m!^http! ) {
690                            $link = $args->{url} . $link;
691                    }
692    
693                          my $nr = $1 || 10;                  my $msg;
694                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
695                    $msg .= prefix( ' by ' , $entry->author );
696                    $msg .= prefix( ' | ' , $entry->title );
697                    $msg .= prefix( ' | ' , $link );
698    #               $msg .= prefix( ' id ' , $entry->id );
699                    my @categories = $entry->category;
700                    warn "## category = ", dump( @categories ) if $debug;
701                    if ( my $tags = $entry->category ) {
702                            $tags = join(' ', @$tags) if ref($tags) eq 'ARRAY';
703                            $tags =~ s!^\s+!!;
704                            $tags =~ s!\s*$! !;
705                            $tags =~ s!,?\s+!// !g;
706                            $msg .= prefix( ' ' , $tags );
707                    }
708    
709                          my $sth = $dbh->prepare(qq{                  if ( $seen_times == 0 && $send_rss_msgs ) {
710                                  select nick,count(*) from log group by nick order by count desc limit $nr                          $send_rss_msgs--;
711                          });                          if ( ! $args->{private} ) {
712                          $sth->execute();                                  # FIXME bug! should be save_message
713                          $res = "Top $nr users: ";                                  save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
714                          my @users;  #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
                         while (my $row = $sth->fetchrow_hashref) {  
                                 push @users,$row->{nick} . ': ' . $row->{count};  
715                          }                          }
716                          $res .= join(" | ", @users);                          my ( $type, $to ) = ( 'notice', $args->{channel} );
717                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                          ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
718    
719                          foreach my $res (get_from_log( limit => $1 )) {                          _log(">> RSS $type to $to:", $msg);
720                                  print "last: $res\n";                          $kernel->post( $irc => $type => $to => $msg );
                                 from_to($res, $ENCODING, 'UTF-8');  
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
                         }  
721    
722                          $res = '';                          $updates++;
723                    }
724            }
725    
726                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {          my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
727            $sql .= qq{, updates = updates + $updates } if $updates;
728            $sql .= qq{where id = } . $args->{id};
729            eval { $dbh->do( $sql ) };
730    
731                          my $what = $2;          _log "RSS $updates/$total new items from", $args->{url};
732    
733                          foreach my $res (get_from_log(          return $updates;
734                                          limit => 20,  }
                                         search => $what,  
                                 )) {  
                                 print "search [$what]: $res\n";  
                                 from_to($res, $ENCODING, 'UTF-8');  
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
                         }  
735    
736                          $res = '';  sub rss_fetch_all {
737            my ( $kernel, $send_rss_msgs )  = @_;
738            warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug;
739            my $sql = qq{
740                    select id, url, name, channel, nick, private
741                    from feeds
742                    where active is true
743            };
744            # limit to newer feeds only if we are not sending messages out
745            $sql .= qq{     and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
746            my $sth = $dbh->prepare( $sql );
747            $sth->execute();
748            warn "# ",$sth->rows," active RSS feeds\n";
749            my $count = 0;
750            while (my $row = $sth->fetchrow_hashref) {
751                    $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs;
752                    $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
753                    $kernel->post(
754                            'rss-fetch',
755                            'request',
756                            'rss_response',
757                            HTTP::Request->new( GET => $row->{url} ),
758                    );
759                    warn "## queued rss-fetch ", dump( $row ) if $debug;
760            }
761            return "OK, scheduled " . $sth->rows . " feeds for refresh";
762    }
763    
764    
765    sub rss_check_updates {
766            my $kernel = shift;
767            $_stat->{rss}->{last_poll} ||= time();
768            my $dt = time() - $_stat->{rss}->{last_poll};
769            if ( $dt > $rss_min_delay ) {
770                    warn "## rss_check_updates $dt > $rss_min_delay\n";
771                    $_stat->{rss}->{last_poll} = time();
772                    _log rss_fetch_all( $kernel );
773            }
774    }
775    
776    sub process_command {
777            my ( $kernel, $nick, $channel, $msg ) = @_;
778    
779            my $res = "unknown command '$msg', try /msg $NICK help!";
780    
781            if ($msg =~ m/^help/i) {
782    
783                    $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
784    
785            } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
786    
787                    _log ">> /$1 $2 $3";
788                    $kernel->post( $irc => $1 => $2, $3 );
789                    $res = '';
790    
791            } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
792    
793                    my $nr = $1 || 10;
794    
795                    my $sth = $dbh->prepare(qq{
796                            select
797                                    trim(both '_' from nick) as nick,
798                                    count(*) as count,
799                                    sum(length(message)) as len
800                            from log
801                            group by trim(both '_' from nick)
802                            order by len desc,count desc
803                            limit $nr
804                    });
805                    $sth->execute();
806                    $res = "Top $nr users: ";
807                    my @users;
808                    while (my $row = $sth->fetchrow_hashref) {
809                            push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
810                  }                  }
811                    $res .= join(" | ", @users);
812            } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
813    
814                  if ($res) {                  my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
815                          print ">> [$nick] $res\n";  
816                          from_to($res, $ENCODING, 'UTF-8');                  foreach my $res (get_from_log( limit => $limit )) {
817                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          _log "last: $res";
818                            $kernel->post( $irc => privmsg => $nick, $res );
819                  }                  }
820    
821          },                  $res = '';
         irc_477 => sub {  
                 print "# irc_477: ",$_[ARG1], "\n";  
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );  
         },  
         irc_505 => sub {  
                 print "# irc_505: ",$_[ARG1], "\n";  
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  
         },  
         irc_registered => sub {  
                 warn "## indetify $NICK\n";  
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
         },  
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
     _child => sub {},  
     _default => sub {  
                 printf "%s #%s %s %s\n",  
                         strftime($TIMESTAMP,localtime()), $_[SESSION]->ID, $_[ARG0],  
                         ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :  
                         $_[ARG1]                                        ?       $_[ARG1]                                        :  
                         "";  
       0;                        # false for signals  
     },  
     my_add => sub {  
       my $trailing = $_[ARG0];  
       my $session = $_[SESSION];  
       POE::Session->create  
           (inline_states =>  
            {_start => sub {  
               $_[HEAP]->{wheel} =  
                 POE::Wheel::FollowTail->new  
                     (  
                      Filename => $FOLLOWS{$trailing},  
                      InputEvent => 'got_line',  
                     );  
             },  
             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  
       }  
822    
823      },          } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
     my_heartbeat => sub {  
       $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep");  
       $_[KERNEL]->delay($_[STATE] => 10);  
     }  
    },  
   );  
824    
825  # tags support                  my $what = $2;
826    
827  my $cloud = HTML::TagCloud->new;                  foreach my $res (get_from_log(
828                                    limit => 20,
829                                    search => $what,
830                            )) {
831                            _log "search [$what]: $res";
832                            $kernel->post( $irc => privmsg => $nick, $res );
833                    }
834    
835  =head2 add_tag                  $res = '';
836    
837   add_tag( id => 42, message => 'irc message' );          } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
838    
839  =cut                  my ($what,$limit) = ($1,$2);
840                    $limit ||= 100;
841    
842  sub add_tag {                  my $stat;
         my $arg = {@_};  
843    
844          return unless ($arg->{id} && $arg->{message});                  foreach my $res (get_from_log(
845                                    limit => $limit,
846                                    search => $what,
847                                    full_rows => 1,
848                            )) {
849                            while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
850                                    $stat->{vote}->{$1}++;
851                                    $stat->{from}->{ $res->{nick} }++;
852                            }
853                    }
854    
855          my $m = $arg->{message};                  my @nicks;
856          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));                  foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
857                            push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
858                                    "(" . $stat->{from}->{$nick} . ")"
859                            );
860                    }
861    
862          while ($m =~ s#$tag_regex##s) {                  $res =
863                  my $tag = $1;                          "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
864                  next if (! $tag || $tag =~ m/https?:/i);                          " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
865                  push @{ $tags->{$tag} }, $arg->{id};                          " from " . ( join(", ", @nicks) || 'nobody' );
866                  #warn "+tag $tag: $arg->{id}\n";  
867                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $kernel->post( $irc => notice => $nick, $res );
868    
869            } elsif ($msg =~ m/^ping/) {
870                    $res = "ping = " . dump( $_stat->{ping} );
871            } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
872                    if ( ! defined( $1 ) ) {
873                            my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
874                            $sth->execute( $nick, $channel );
875                            $res = "config for $nick on $channel";
876                            while ( my ($n,$v) = $sth->fetchrow_array ) {
877                                    $res .= " | $n = $v";
878                            }
879                    } elsif ( ! $2 ) {
880                            my $val = meta( $nick, $channel, $1 );
881                            $res = "current $1 = " . ( $val ? $val : 'undefined' );
882                    } else {
883                            my $validate = {
884                                    'last-size' => qr/^\d+/,
885                                    'twitter' => qr/^\w+\s+\w+/,
886                            };
887    
888                            my ( $op, $val ) = ( $1, $2 );
889    
890                            if ( my $regex = $validate->{$op} ) {
891                                    if ( $val =~ $regex ) {
892                                            meta( $nick, $channel, $op, $val );
893                                            $res = "saved $op = $val";
894                                    } else {
895                                            $res = "config option $op = $val doesn't validate against $regex";
896                                    }
897                            } else {
898                                    $res = "config option $op doesn't exist";
899                            }
900                    }
901            } elsif ($msg =~ m/^rss-update/) {
902                    $res = rss_fetch_all( $kernel );
903            } elsif ($msg =~ m/^rss-list/) {
904                    my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
905                    $sth->execute;
906                    while (my @row = $sth->fetchrow_array) {
907                            $kernel->post( $irc => privmsg => $nick, join(' | ',@row) );
908                    }
909                    $res = '';
910            } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
911                    my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
912    
913                    my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
914                    $channel = $nick if $sub eq 'private';
915    
916                    my $sql = {
917                            add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
918                            remove  => qq{ delete from feeds                                where url = ? and nick = ? },
919                            start   => qq{ update feeds set active = true   where url = ? },
920                            stop    => qq{ update feeds set active = false  where url = ? },
921                            clean   => qq{ update feeds set last_update = now() - delay where url = ? },
922                    };
923    
924                    if ( $command eq 'add' && ! $channel ) {
925                            $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
926                    } elsif (my $q = $sql->{$command} ) {
927                            my $sth = $dbh->prepare( $q );
928                            my @data = ( $url );
929                            if ( $command eq 'add' ) {
930                                    push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
931                            } elsif ( $command eq 'remove' ) {
932                                    push @data, $nick;
933                            }
934                            warn "## $command SQL $q with ",dump( @data ),"\n";
935                            eval { $sth->execute( @data ) };
936                            if ($@) {
937                                    $res = "ERROR: $@";
938                            } else {
939                                    $res = "OK, RSS executed $command" .
940                                            ( $sub ? "-$sub " : ' ' ) .
941                                            ( $channel ? "on $channel " : '' ) .
942                                            "url $url";
943                                    if ( $command eq 'clean' ) {
944                                            my $seen = $_stat->{rss}->{seen} || die "no seen?";
945                                            my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
946                                            foreach my $c ( keys %$seen ) {
947                                                    my $c_hash = $seen->{$c} || die "no seen->{$c}";
948                                                    die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
949                                                    foreach my $link ( keys %$c_hash ) {
950                                                            next unless $link eq $want_link;
951                                                            _log "RSS removed seen $c $url $link";
952                                                    }
953                                            }
954                                    } elsif ( $command eq 'add' ) {
955                                            rss_fetch_all( $kernel );
956                                    }
957                            }
958                    } else {
959                            $res = "ERROR: don't know what to do with: $msg";
960                    }
961            } elsif ($msg =~ m/^rss-clean/) {
962                    # this makes sense because we didn't catch rss-clean http://... before!
963                    $_stat->{rss} = undef;
964                    $dbh->do( qq{ update feeds set last_update = now() - delay } );
965                    $res = rss_fetch_all( $kernel );
966          }          }
967    
968            return $res;
969  }  }
970    
971  =head2 seed_tags  POE::Session->create( inline_states => {
972            _start => sub {      
973                    $_[KERNEL]->post( $irc => register => 'all' );
974                    $_[KERNEL]->post( $irc => connect => {} );
975        },
976            irc_001 => sub {
977                    my ($kernel,$sender) = @_[KERNEL,SENDER];
978                    my $poco_object = $sender->get_heap();
979                    _log "connected to",$poco_object->server_name();
980                    $kernel->post( $sender => join => $_ ) for @channels;
981                    # seen RSS cache, so don't send out messages
982                    _log rss_fetch_all( $kernel, 0 );
983                    undef;
984            },
985    #       irc_255 => sub {        # server is done blabbing
986    #               $_[KERNEL]->post( $irc => join => $CHANNEL);
987    #       },
988        irc_public => sub {
989                    my $kernel = $_[KERNEL];
990                    my $nick = (split /!/, $_[ARG0])[0];
991                    my $channel = $_[ARG1]->[0];
992                    my $msg = $_[ARG2];
993    
994  Read all tags from database and create in-memory cache for tags                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
995                    meta( $nick, $channel, 'last-msg', $msg );
996                    rss_check_updates( $kernel );
997        },
998        irc_ctcp_action => sub {
999                    my $kernel = $_[KERNEL];
1000                    my $nick = (split /!/, $_[ARG0])[0];
1001                    my $channel = $_[ARG1]->[0];
1002                    my $msg = $_[ARG2];
1003    
1004  =cut                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
1005    
1006  sub seed_tags {                  if ( $use_twitter ) {
1007          my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
1008          $sth->execute;                                  my ($login,$passwd) = split(/\s+/,$twitter,2);
1009          while (my $row = $sth->fetchrow_hashref) {                                  _log("sending twitter for $nick/$login on $channel ");
1010                  add_tag( %$row );                                  my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
1011          }                                  $bot->update("<${channel}> $msg");
1012                            }
1013                    }
1014    
1015          foreach my $tag (keys %$tags) {      },
1016                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);          irc_ping => sub {
1017          }                  _log( "pong ", $_[ARG0] );
1018  }                  $_stat->{ping}->{ $_[ARG0] }++;
1019                    rss_check_updates( $_[KERNEL] );
1020            },
1021            irc_invite => sub {
1022                    my $kernel = $_[KERNEL];
1023                    my $nick = (split /!/, $_[ARG0])[0];
1024                    my $channel = $_[ARG1];
1025    
1026  seed_tags;                  _log "invited to $channel by $nick";
1027    
1028                    $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
1029                    $_[KERNEL]->post( $irc => 'join' => $channel );
1030    
1031            },
1032            irc_msg => sub {
1033                    my $kernel = $_[KERNEL];
1034                    my $nick = (split /!/, $_[ARG0])[0];
1035                    my $channel = $_[ARG1]->[0];
1036                    my $msg = $_[ARG2];
1037                    warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
1038    
1039                    _log "<< $msg";
1040    
1041                    my $res = process_command( $_[KERNEL], $nick, $channel, $msg );
1042    
1043                    if ($res) {
1044                            _log ">> [$nick] $res";
1045                            $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1046                    }
1047    
1048                    rss_check_updates( $_[KERNEL] );
1049            },
1050            irc_372 => sub {
1051                    _log "<< motd",$_[ARG0],$_[ARG1];
1052            },
1053            irc_375 => sub {
1054                    _log "<< motd", $_[ARG0], "start";
1055            },
1056            irc_376 => sub {
1057                    _log "<< motd", $_[ARG0], "end";
1058            },
1059    #       irc_433 => sub {
1060    #               print "# irc_433: ",$_[ARG1], "\n";
1061    #               warn "## indetify $NICK\n";
1062    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1063    #       },
1064    #       irc_451 # please register
1065            irc_477 => sub {
1066                    _log "<< irc_477: ",$_[ARG1];
1067                    _log ">> IDENTIFY $NICK";
1068                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1069            },
1070            irc_505 => sub {
1071                    _log "<< irc_505: ",$_[ARG1];
1072                    _log ">> register $NICK";
1073                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1074    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1075    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1076    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1077            },
1078            irc_registered => sub {
1079                    _log "<< registered $NICK";
1080            },
1081            irc_disconnected => sub {
1082                    _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1083                    sleep($sleep_on_error);
1084                    $_[KERNEL]->post( $irc => connect => {} );
1085            },
1086            irc_socketerr => sub {
1087                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1088                    sleep($sleep_on_error);
1089                    $_[KERNEL]->post( $irc => connect => {} );
1090            },
1091            irc_notice => sub {
1092                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1093                    my $m = $_[ARG2];
1094                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1095                            _log ">> suggested to $1 $2";
1096                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1097                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1098                            _log ">> registreted, so IDENTIFY";
1099                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1100                    } else {
1101                            warn "## ignore $m\n" if $debug;
1102                    }
1103            },
1104            irc_snotice => sub {
1105                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1106                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1107                            warn ">> $1 | $2\n";
1108                            $_[KERNEL]->post( $irc => lc($1) => $2);
1109                    }
1110            },
1111        _child => sub {},
1112        _default => sub {
1113                    _log '_default SID:', $_[SESSION]->ID, $_[ARG0], dump( $_[ARG1] );
1114                    0; # false for signals
1115        },
1116            rss_response => sub {
1117                    my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1118                    my $request_object  = $request_packet->[0];
1119                    my $response_object = $response_packet->[0];
1120    
1121                    my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1122                    if ( $row ) {
1123                            $row->{xml} = $response_object->content;
1124                            rss_parse_xml( $_[KERNEL], $row );
1125                    } else {
1126                            warn "## can't find rss->fetch for ", $request_object->uri;
1127                    }
1128            },
1129       },
1130      );
1131    
1132  # http server  # http server
1133    
1134    _log "WEB archive at $url";
1135    
1136  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1137          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1138            PreHandler => {
1139                    '/' => sub {
1140                            $_[0]->header(Connection => 'close')
1141                    }
1142            },
1143          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1144          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1145  );  );
1146    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1147  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1148  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1149  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 560  p { margin: 0; padding: 0.1em; } Line 1151  p { margin: 0; padding: 0.1em; }
1151  .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 ; }
1152  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1153  .search { float: right; }  .search { float: right; }
1154    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1155    a:hover.tag { border: 1px solid #eee }
1156    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1157    /*
1158  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1159  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1160  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1161  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1162  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1163  a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }  */
1164  a:hover.tag { border: 1px solid #eee }  .calendar { border: 1px solid red; width: 100%; }
1165  hr { border: 1px dashed #ccc; height: 1px; clear: both; }  .month { border: 0px; width: 100%; }
1166  _END_OF_STYLE_  _END_OF_STYLE_
1167    
1168  my $max_color = 4;  $max_color = 0;
1169    
1170  my %nick_enumerator;  my @cols = qw(
1171            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1172            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1173            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1174            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1175            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1176    );
1177    
1178    foreach my $c (@cols) {
1179            $style .= ".col-${max_color} { background: $c }\n";
1180            $max_color++;
1181    }
1182    _log "WEB defined $max_color colors for users...";
1183    
1184  sub root_handler {  sub root_handler {
1185          my ($request, $response) = @_;          my ($request, $response) = @_;
1186          $response->code(RC_OK);          $response->code(RC_OK);
1187          $response->content_type("text/html; charset=$ENCODING");  
1188            # this doesn't seem to work, so moved to PreHandler
1189            #$response->header(Connection => 'close');
1190    
1191            return RC_OK if $request->uri =~ m/favicon.ico$/;
1192    
1193            if ( $request->uri =~ m/robots.txt$/ ) {
1194                    $response->content_type( 'text/plain' );
1195                    $response->content( qq{
1196    
1197    User-Agent: *
1198    Disallow: /
1199    
1200                    });
1201                    return RC_OK;
1202            }
1203    
1204          my $q;          my $q;
1205    
# Line 590  sub root_handler { Line 1212  sub root_handler {
1212          }          }
1213    
1214          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1215            my $r_url = $request->url;
1216    
1217            my @commands = qw( tags last-tag follow stat );
1218            my $commands_re = join('|',@commands);
1219    
1220            if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1221                    my $show = lc($1);
1222                    my $nr = $2;
1223    
1224                    my $type = 'RSS';       # Atom
1225    
1226                    $response->content_type( 'application/' . lc($type) . '+xml' );
1227    
1228                    my $html = '<!-- error -->';
1229                    #warn "create $type feed from ",dump( $cloud->last_tags );
1230    
1231                    my $feed = XML::Feed->new( $type );
1232                    $feed->link( $url );
1233    
1234                    my $rc = RC_OK;
1235    
1236                    if ( $show eq 'tags' ) {
1237                            $nr ||= 50;
1238                            $feed->title( "tags from $CHANNEL" );
1239                            $feed->link( "$url/tags" );
1240                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1241                            my $feed_entry = XML::Feed::Entry->new($type);
1242                            $feed_entry->title( "$nr tags from $CHANNEL" );
1243                            $feed_entry->author( $NICK );
1244                            $feed_entry->link( '/#tags'  );
1245    
1246                            $feed_entry->content(
1247                                    qq{<![CDATA[<style type="text/css">}
1248                                    . $cloud->css
1249                                    . qq{</style>}
1250                                    . $cloud->html( $nr )
1251                                    . qq{]]>}
1252                            );
1253                            $feed->add_entry( $feed_entry );
1254    
1255                    } elsif ( $show eq 'last-tag' ) {
1256    
1257                            $nr ||= $last_x_tags;
1258                            $nr = $last_x_tags if $nr > $last_x_tags;
1259    
1260                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1261                            $feed->description( "collects messages which have tags// in them" );
1262    
1263                            foreach my $m ( $cloud->last_tags ) {
1264    #                               warn dump( $m );
1265                                    #my $tags = join(' ', @{$m->{tags}} );
1266                                    my $feed_entry = XML::Feed::Entry->new($type);
1267                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1268                                    $feed_entry->author( $m->{nick} );
1269                                    $feed_entry->link( '/#' . $m->{id}  );
1270                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1271    
1272                                    my $message = $filter->{message}->( $m->{message} );
1273                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1274    #                               warn "## message = $message\n";
1275    
1276                                    #$feed_entry->summary(
1277                                    $feed_entry->content(
1278                                            "<![CDATA[$message]]>"
1279                                    );
1280                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1281                                    $feed->add_entry( $feed_entry );
1282    
1283                                    $nr--;
1284                                    last if $nr <= 0;
1285    
1286                            }
1287    
1288                    } elsif ( $show =~ m/^follow/ ) {
1289    
1290                            $feed->title( "Feeds which this bot follows" );
1291    
1292                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1293                            $sth->execute;
1294                            while (my $row = $sth->fetchrow_hashref) {
1295                                    my $feed_entry = XML::Feed::Entry->new($type);
1296                                    $feed_entry->title( $row->{name} );
1297                                    $feed_entry->link( $row->{url}  );
1298                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1299                                    $feed_entry->content(
1300                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1301                                    );
1302                                    $feed->add_entry( $feed_entry );
1303                            }
1304    
1305                    } elsif ( $show =~ m/^stat/ ) {
1306    
1307                            my $feed_entry = XML::Feed::Entry->new($type);
1308                            $feed_entry->title( "Internal stats" );
1309                            $feed_entry->content(
1310                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1311                            );
1312                            $feed->add_entry( $feed_entry );
1313    
1314                    } else {
1315                            _log "WEB unknown rss request $r_url";
1316                            $feed->title( "unknown $r_url" );
1317                            foreach my $c ( @commands ) {
1318                                    my $feed_entry = XML::Feed::Entry->new($type);
1319                                    $feed_entry->title( "rss/$c" );
1320                                    $feed_entry->link( "$url/rss/$c" );
1321                                    $feed->add_entry( $feed_entry );
1322                            }
1323                            $rc = RC_DENY;
1324                    }
1325    
1326                    eval { $response->content( $feed->as_xml ); };
1327                    $rc = RC_INTERNAL_SERVER_ERROR if $@;
1328                    return $rc;
1329            }
1330    
1331            if ( $@ ) {
1332                    warn "$@";
1333            }
1334    
1335            $response->content_type("text/html; charset=UTF-8");
1336    
1337          my $html =          my $html =
1338                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1339                  $cloud->css .                  . $cloud->css
1340                  qq{</style></head><body>} .                  . qq{</style>
1341                  qq{                  <meta name="google-site-verification" content="oe-LvUiNiQRPpc_uB-3rY4MWvFifkmLf276WzAvTL5U" />  
1342                    </head><body>}
1343                    . qq{
1344                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1345                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1346                  <input type="submit" value="search">                  <input type="submit" value="search">
1347                  </form>                  </form>
1348                  } .                  }
1349                  $cloud->html(500) .                  . $cloud->html(500)
1350                  qq{<p>};                  . qq{<p>};
1351          if ($request->url =~ m#/history#) {  
1352            if ($request->url =~ m#/tags?#) {
1353                    # nop
1354            } elsif ($request->url =~ m#/history#) {
1355                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1356                          select date(time) as date,count(*) as nr                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1357                                  from log                                  from log
1358                                  group by date(time)                                  group by date(time)
1359                                  order by date(time) desc                                  order by date(time) desc
1360                  });                  });
1361                  $sth->execute();                  $sth->execute();
1362                  my ($l_yyyy,$l_mm) = (0,0);                  my ($l_yyyy,$l_mm) = (0,0);
1363                    $html .= qq{<table class="calendar"><tr>};
1364                  my $cal;                  my $cal;
1365                    my $ord = 0;
1366                  while (my $row = $sth->fetchrow_hashref) {                  while (my $row = $sth->fetchrow_hashref) {
1367                          # this is probably PostgreSQL specific, expects ISO date                          # this is probably PostgreSQL specific, expects ISO date
1368                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1369                          if ($yyyy != $l_yyyy || $mm != $l_mm) {                          if ($yyyy != $l_yyyy || $mm != $l_mm) {
1370                                  $html .= $cal->as_HTML() if ($cal);                                  if ( $cal ) {
1371                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1372                                            $ord++;
1373                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1374                                    }
1375                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1376                                  $cal->border(2);                                  $cal->border(1);
1377                                    $cal->width('30%');
1378                                    $cal->cellheight('5em');
1379                                    $cal->tableclass('month');
1380                                    #$cal->cellclass('day');
1381                                    $cal->sunday('SUN');
1382                                    $cal->saturday('SAT');
1383                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1384                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1385                          }                          }
1386                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1387                                  <a href="/?date=$row->{date}">$row->{nr}</a>                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1388                          });                          ]) if $cal;
1389                            
1390                  }                  }
1391                  $html .= $cal->as_HTML() if ($cal);                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1392    
1393          } else {          } else {
1394                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1395                          get_from_log(                          get_from_log(
1396                                  limit => $q->param('last') || $q->param('date') ? undef : 100,                                  limit => ( $q->param('date') ? undef : $q->param('last') || 100 ),
1397                                  search => $search || undef,                                  search => $search || undef,
1398                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1399                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
1400                                  fmt => {                                  fmt => {
1401                                          date => sub {                                          date => sub {
1402                                                  my $date = shift || return;                                                  my $date = shift || return;
1403                                                  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>};
1404                                          },                                          },
1405                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1406                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 646  sub root_handler { Line 1408  sub root_handler {
1408                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1409                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1410                                  },                                  },
1411                                  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>';  
                                         },  
                                 },  
1412                          )                          )
1413                  );                  );
1414          }          }
# Line 675  sub root_handler { Line 1419  sub root_handler {
1419          </body></html>};          </body></html>};
1420    
1421          $response->content( $html );          $response->content( $html );
1422            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1423          return RC_OK;          return RC_OK;
1424  }  }
1425    
1426  POE::Kernel->run;  POE::Kernel->run;
1427    
1428    =head1 TagCloud
1429    
1430    Extended L<HTML::TagCloud>
1431    
1432    =cut
1433    
1434    package TagCloud;
1435    use warnings;
1436    use strict;
1437    use HTML::TagCloud;
1438    use base 'HTML::TagCloud';
1439    use Data::Dump qw/dump/;
1440    
1441    =head2 html
1442    
1443    Generate html with number of tags in title of link
1444    
1445    =cut
1446    
1447    sub html {
1448            my($self, $limit) = @_;
1449            my @tags=$self->tags($limit);
1450    
1451            my $ntags = scalar(@tags);
1452            if ($ntags == 0) {
1453                    return "";
1454    #       } elsif ($ntags == 1) {
1455    #               my $tag = $tags[0];
1456    #               return qq{<div id="htmltagcloud"><span class="tagcloud1"><a href="}.
1457    #               $tag->{url}.qq{">}.$tag->{name}.qq{</a></span></div>\n};
1458            }
1459    
1460      my $html = qq{<div id="htmltagcloud">};
1461      foreach my $tag ( sort { lc($a->{name}) cmp lc($b->{name}) } @tags) {
1462        $html .=  sprintf(qq{<span class="tag tagcloud%d"><a href="%s" title="%s">%s</a></span>\n},
1463                    $tag->{level}, $tag->{url}, $tag->{count}, $tag->{name}
1464            );
1465      }
1466      $html .= qq{</div>};
1467      return $html;
1468    }
1469    
1470    =head2 last_tags
1471    
1472      my @tags = $cloud->last_tags;
1473    
1474    =cut
1475    
1476    my @last_tags;
1477    sub last_tags {
1478            return @last_tags;
1479    }
1480    
1481    =head2 add_tag
1482    
1483     $cloud->add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
1484    
1485    =cut
1486    
1487    
1488    sub add_tag {
1489            my $self = shift;
1490            my $arg = {@_};
1491    
1492            return unless ($arg->{id} && $arg->{message});
1493    
1494            my $m = $arg->{message};
1495    
1496            my @tags;
1497    
1498            while ($m =~ s#$tag_regex##s) {
1499                    my $tag = $1;
1500                    next if (! $tag || $tag =~ m/https?:/i);
1501                    push @{ $tags->{$tag} }, $arg->{id};
1502                    #warn "+tag $tag: $arg->{id}\n";
1503                    $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1504                    push @tags, $tag;
1505    
1506            }
1507    
1508            if ( @tags ) {
1509                    pop @last_tags if $#last_tags == $last_x_tags;
1510                    unshift @last_tags, { tags => [ @tags ], %$arg };
1511            }
1512    
1513    }
1514    
1515    =head2 seed_tags
1516    
1517    Read all tags from database and create in-memory cache for tags
1518    
1519    =cut
1520    
1521    sub seed_tags {
1522            my $self = shift;
1523            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
1524            $sth->execute;
1525            while (my $row = $sth->fetchrow_hashref) {
1526                    $self->add_tag( %$row );
1527            }
1528    
1529            foreach my $tag (keys %$tags) {
1530                    $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1531            }
1532    }
1533    
Legend:
Removed from v.36  
changed lines
  Added in v.150
  ViewVC Help
Powered by ViewVC 1.1.26