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