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