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