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