/[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

revision 72 by dpavlin, Sun Dec 16 19:03:35 2007 UTC revision 95 by dpavlin, Fri Mar 7 11:16:05 2008 UTC
# Line 20  Import log from C<dircproxy> to C<irc-lo Line 20  Import log from C<dircproxy> to C<irc-lo
20    
21  =item --log=irc-logger.log  =item --log=irc-logger.log
22    
 Name of log file  
   
23  =back  =back
24    
25  =head1 DESCRIPTION  =head1 DESCRIPTION
# Line 32  log all conversation on irc channel Line 30  log all conversation on irc channel
30    
31  ## CONFIG  ## CONFIG
32    
33  my $HOSTNAME = `hostname`;  my $HOSTNAME = `hostname -f`;
34    chomp($HOSTNAME);
35    
36  my $NICK = 'irc-logger';  my $NICK = 'irc-logger';
37  $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
# Line 45  my $CHANNEL = '#razmjenavjestina'; Line 44  my $CHANNEL = '#razmjenavjestina';
44  $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
45  my $IRC_ALIAS = "log";  my $IRC_ALIAS = "log";
46    
 my %FOLLOWS =  
   (  
    ACCESS => "/var/log/apache/access.log",  
    ERROR => "/var/log/apache/error.log",  
   );  
   
47  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
48    
 my $ENCODING = 'ISO-8859-2';  
49  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
50    
51  my $sleep_on_error = 5;  my $sleep_on_error = 5;
52    
53  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;  # number of last tags to keep in circular buffer
54  my $http_hostname = `hostname`;  my $last_x_tags = 50;
 chomp( $http_hostname );  
55    
56  ## END CONFIG  # don't pull rss feeds more often than this
57    my $rss_min_delay = 60;
58    
59    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
60    
61    my $url = "http://$HOSTNAME:$http_port";
62    
63    ## END CONFIG
64    
65  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  use POE qw(Component::IRC Component::Server::HTTP);
66  use HTTP::Status;  use HTTP::Status;
67  use DBI;  use DBI;
 use Encode qw/from_to is_utf8/;  
68  use Regexp::Common qw /URI/;  use Regexp::Common qw /URI/;
69  use CGI::Simple;  use CGI::Simple;
70  use HTML::TagCloud;  use HTML::TagCloud;
# Line 95  GetOptions( Line 90  GetOptions(
90          'log:s' => \$log_path,          'log:s' => \$log_path,
91  );  );
92    
93  $SIG{__DIE__} = sub {  #$SIG{__DIE__} = sub {
94          confess "fatal error";  #       confess "fatal error";
95  };  #};
96    
97  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
98    
99  sub _log {  sub _log {
100          print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
101  }  }
102    
103  # HTML formatters  # HTML formatters
# Line 128  my $filter = { Line 123  my $filter = {
123                  $m =~ s/($escape_re)/$escape{$1}/gs;                  $m =~ s/($escape_re)/$escape{$1}/gs;
124                  $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs ||                  $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs ||
125                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
126                  $m =~ s#$tag_regex#e(qq{<a href="?tag=$1" class="tag">$1</a>})#egs;                  $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
127                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
128                  $m =~ s#_(\w+)_#<u>$1</u>#gs;                  $m =~ s#_(\w+)_#<u>$1</u>#gs;
129    
# Line 148  my $filter = { Line 143  my $filter = {
143  };  };
144    
145  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
146    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
147    
148  my $sql_schema = {  my $sql_schema = {
149          log => '          log => qq{
150  create table log (  create table log (
151          id serial,          id serial,
152          time timestamp default now(),          time timestamp default now(),
# Line 164  create table log ( Line 160  create table log (
160  create index log_time on log(time);  create index log_time on log(time);
161  create index log_channel on log(channel);  create index log_channel on log(channel);
162  create index log_nick on log(nick);  create index log_nick on log(nick);
163          ',          },
164          meta => '          meta => q{
165  create table meta (  create table meta (
166          nick text not null,          nick text not null,
167          channel text not null,          channel text not null,
168          name text not null,          name text not null,
169          value text,          value text,
170          changed timestamp default now(),          changed timestamp default 'now()',
171          primary key(nick,channel,name)          primary key(nick,channel,name)
172  );  );
173          ',          },
174            feeds => qq{
175    create table feeds (
176            id serial,
177            url text not null,
178            name text,
179            delay interval not null default '5 min',
180            active boolean default true,
181            last_update timestamp default 'now()',
182            polls int default 0,
183            updates int default 0
184    );
185    create unique index feeds_url on feeds(url);
186    insert into feeds (url,name) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki');
187            },
188  };  };
189    
190  foreach my $table ( keys %$sql_schema ) {  foreach my $table ( keys %$sql_schema ) {
# Line 217  sub meta { Line 227  sub meta {
227                  if ( $@ || ! $sth->rows ) {                  if ( $@ || ! $sth->rows ) {
228                          $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });                          $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
229                          $sth->execute( $value, $nick, $channel, $name );                          $sth->execute( $value, $nick, $channel, $name );
230                          _log "created $nick/$channel/$name = $value";                          warn "## created $nick/$channel/$name = $value\n";
231                  } else {                  } else {
232                          _log "updated $nick/$channel/$name = $value ";                          warn "## updated $nick/$channel/$name = $value\n";
233                  }                  }
234    
235                  return $value;                  return $value;
# Line 229  sub meta { Line 239  sub meta {
239                  my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });                  my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
240                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
241                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
242                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
243                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
244                  return $v;                  return $v;
245    
# Line 238  sub meta { Line 248  sub meta {
248    
249    
250    
251  my $sth = $dbh->prepare(qq{  my $sth_insert_log = $dbh->prepare(qq{
252  insert into log  insert into log
253          (channel, me, nick, message, time)          (channel, me, nick, message, time)
254  values (?,?,?,?,?)  values (?,?,?,?,?)
# Line 482  my $cloud = HTML::TagCloud->new; Line 492  my $cloud = HTML::TagCloud->new;
492    
493  =cut  =cut
494    
 my $last_x_tags = 5;  
495  my @last_tags;  my @last_tags;
496    
497  sub add_tag {  sub add_tag {
# Line 491  sub add_tag { Line 500  sub add_tag {
500          return unless ($arg->{id} && $arg->{message});          return unless ($arg->{id} && $arg->{message});
501    
502          my $m = $arg->{message};          my $m = $arg->{message};
         from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
503    
504          my @tags;          my @tags;
505    
# Line 500  sub add_tag { Line 508  sub add_tag {
508                  next if (! $tag || $tag =~ m/https?:/i);                  next if (! $tag || $tag =~ m/https?:/i);
509                  push @{ $tags->{$tag} }, $arg->{id};                  push @{ $tags->{$tag} }, $arg->{id};
510                  #warn "+tag $tag: $arg->{id}\n";                  #warn "+tag $tag: $arg->{id}\n";
511                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
512                  push @tags, $tag;                  push @tags, $tag;
513    
514          }          }
515    
516          if ( @tags ) {          if ( @tags ) {
517                  shift @last_tags if $#last_tags == $last_x_tags;                  pop @last_tags if $#last_tags == $last_x_tags;
518                  push @last_tags, { tags => [ @tags ], %$arg };                  unshift @last_tags, { tags => [ @tags ], %$arg };
519          }          }
520    
521  }  }
# Line 519  Read all tags from database and create i Line 527  Read all tags from database and create i
527  =cut  =cut
528    
529  sub seed_tags {  sub seed_tags {
530          my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' });          my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
531          $sth->execute;          $sth->execute;
532          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
533                  add_tag( %$row );                  add_tag( %$row );
534          }          }
535    
536          foreach my $tag (keys %$tags) {          foreach my $tag (keys %$tags) {
537                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
538          }          }
539  }  }
540    
# Line 560  sub save_message { Line 568  sub save_message {
568                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
569                  " " . $a->{message};                  " " . $a->{message};
570    
571          from_to($a->{message}, 'UTF-8', $ENCODING);          $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
   
         $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});  
572          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
573  }  }
574    
# Line 601  if ($import_dircproxy) { Line 607  if ($import_dircproxy) {
607          exit;          exit;
608  }  }
609    
610    #
611    # RSS follow
612    #
613    
614    my $_rss;
615    
616    
617    sub rss_fetch {
618            my ($args) = @_;
619    
620            # how many messages to send out when feed is seen for the first time?
621            my $send_rss_msgs = 1;
622    
623            _log "RSS fetch", $args->{url};
624    
625            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
626            if ( ! $feed ) {
627                    _log("can't fetch RSS ", $args->{url});
628                    return;
629            }
630    
631            my ( $total, $updates ) = ( 0, 0 );
632            for my $entry ($feed->entries) {
633                    $total++;
634    
635                    # seen allready?
636                    next if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;
637    
638                    sub prefix {
639                            my ($txt,$var) = @_;
640                            $var =~ s/\s+/ /gs;
641                            $var =~ s/^\s+//g;
642                            $var =~ s/\s+$//g;
643                            return $txt . $var if $var;
644                    }
645    
646                    # fix absolute and relative links to feed entries
647                    my $link = $entry->link;
648                    if ( $link =~ m!^/! ) {
649                            my $host = $args->{url};
650                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
651                            $link = "$host/$link";
652                    } elsif ( $link !~ m!^http! ) {
653                            $link = $args->{url} . $link;
654                    }
655                    $link =~ s!//+!/!g;
656    
657                    my $msg;
658                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
659                    $msg .= prefix( ' by ' , $entry->author );
660                    $msg .= prefix( ' | ' , $entry->title );
661                    $msg .= prefix( ' | ' , $link );
662    #               $msg .= prefix( ' id ' , $entry->id );
663    
664                    if ( $args->{kernel} && $send_rss_msgs ) {
665                            $send_rss_msgs--;
666                            _log('>>', $msg);
667                            $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, 'now()' );
668                            $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );
669                            $updates++;
670                    }
671            }
672    
673            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
674            $sql .= qq{, updates = updates + $updates } if $updates;
675            $sql .= qq{where id = } . $args->{id};
676            eval { $dbh->do( $sql ) };
677    
678            _log "RSS got $total items of which $updates new";
679    
680            return $updates;
681    }
682    
683    sub rss_fetch_all {
684            my $kernel = shift;
685            my $sql = qq{
686                    select id, url, name
687                    from feeds
688                    where active is true
689            };
690            # limit to newer feeds only if we are not sending messages out
691            $sql .= qq{     and last_update + delay < now() } if $kernel;
692            my $sth = $dbh->prepare( $sql );
693            $sth->execute();
694            warn "# ",$sth->rows," active RSS feeds\n";
695            my $count = 0;
696            while (my $row = $sth->fetchrow_hashref) {
697                    $row->{kernel} = $kernel if $kernel;
698                    $count += rss_fetch( $row );
699            }
700            return "OK, fetched $count posts from " . $sth->rows . " feeds";
701    }
702    
703    
704    sub rss_check_updates {
705            my $kernel = shift;
706            $_rss->{last_poll} ||= time();
707            my $dt = time() - $_rss->{last_poll};
708            warn "## rss_check_updates $dt > $rss_min_delay\n";
709            if ( $dt > $rss_min_delay ) {
710                    $_rss->{last_poll} = time();
711                    _log rss_fetch_all( $kernel );
712            }
713    }
714    
715    # seed rss seen cache so we won't send out all items on startup
716    _log rss_fetch_all;
717    
718  #  #
719  # POE handing part  # POE handing part
720  #  #
721    
 my $SKIPPING = 0;               # if skipping, how many we've done  
 my $SEND_QUEUE;                 # cache  
722  my $ping;                                               # ping stats  my $ping;                                               # ping stats
723    
724  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
725    
726  POE::Session->create( inline_states =>  POE::Session->create( inline_states => {
727     {_start => sub {                _start => sub {      
728                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
729                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
730      },      },
731      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
732                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
                 $_[KERNEL]->post($IRC_ALIAS => join => '#logger');  
                 $_[KERNEL]->yield("heartbeat"); # start heartbeat  
 #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  
733                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
734      },      },
735      irc_public => sub {      irc_public => sub {
# Line 632  POE::Session->create( inline_states => Line 740  POE::Session->create( inline_states =>
740    
741                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
742                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
743                    rss_check_updates( $kernel );
744      },      },
745      irc_ctcp_action => sub {      irc_ctcp_action => sub {
746                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 652  POE::Session->create( inline_states => Line 761  POE::Session->create( inline_states =>
761    
762      },      },
763          irc_ping => sub {          irc_ping => sub {
764                  warn "pong ", $_[ARG0], $/;                  _log( "pong ", $_[ARG0] );
765                  $ping->{ $_[ARG0] }++;                  $ping->{ $_[ARG0] }++;
766                    rss_check_updates( $_[KERNEL] );
767          },          },
768          irc_invite => sub {          irc_invite => sub {
769                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
770                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
771                  my $channel = $_[ARG1];                  my $channel = $_[ARG1];
772    
773                  warn "invited to $channel by $nick";                  _log "invited to $channel by $nick";
774    
775                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
776                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);
# Line 671  POE::Session->create( inline_states => Line 781  POE::Session->create( inline_states =>
781                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
782                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
783                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
                 from_to($msg, 'UTF-8', $ENCODING);  
784    
785                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
786                  my @out;                  my @out;
# Line 715  POE::Session->create( inline_states => Line 824  POE::Session->create( inline_states =>
824    
825                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
826                                  _log "last: $res";                                  _log "last: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
827                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
828                          }                          }
829    
# Line 730  POE::Session->create( inline_states => Line 838  POE::Session->create( inline_states =>
838                                          search => $what,                                          search => $what,
839                                  )) {                                  )) {
840                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
841                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
842                          }                          }
843    
# Line 800  POE::Session->create( inline_states => Line 907  POE::Session->create( inline_states =>
907                                          $res = "config option $op doesn't exist";                                          $res = "config option $op doesn't exist";
908                                  }                                  }
909                          }                          }
910                    } elsif ($msg =~ m/^rss-update/) {
911                            $res = rss_fetch_all( $_[KERNEL] );
912                    } elsif ($msg =~ m/^rss-clean/) {
913                            $_rss = undef;
914                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
915                            $res = "OK, cleaned RSS cache";
916                    } elsif ($msg =~ m/^rss-list/) {
917                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active from feeds });
918                            $sth->execute;
919                            while (my @row = $sth->fetchrow_array) {
920                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
921                            }
922                            $res = '';
923                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {
924                            my $sql = {
925                                    add             => qq{ insert into feeds (url,name) values (?,?) },
926    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
927                                    start   => qq{ update feeds set active = true   where url = ? },
928                                    stop    => qq{ update feeds set active = false  where url = ? },
929                            };
930                            if (my $q = $sql->{$1} ) {
931                                    my $sth = $dbh->prepare( $q );
932                                    my @data = ( $2 );
933                                    push @data, $3 if ( $q =~ s/\?//g == 2 );
934                                    warn "## $1 SQL $q with ",dump( @data ),"\n";
935                                    eval { $sth->execute( @data ) };
936                            }
937    
938                            $res = "OK, RSS $1 : $2 - $3";
939                  }                  }
940    
941                  if ($res) {                  if ($res) {
942                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
                         from_to($res, $ENCODING, 'UTF-8');  
943                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
944                  }                  }
945    
946                    rss_check_updates( $_[KERNEL] );
947          },          },
948          irc_477 => sub {          irc_477 => sub {
949                  _log "# irc_477: ",$_[ARG1];                  _log "# irc_477: ",$_[ARG1];
# Line 846  POE::Session->create( inline_states => Line 982  POE::Session->create( inline_states =>
982                          "";                          "";
983        0;                        # false for signals        0;                        # false for signals
984      },      },
     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);  
     }  
985     },     },
986    );    );
987    
# Line 913  POE::Session->create( inline_states => Line 989  POE::Session->create( inline_states =>
989    
990  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
991          Port => $http_port,          Port => $http_port,
992            PreHandler => {
993                    '/' => sub {
994                            $_[0]->header(Connection => 'close')
995                    }
996            },
997          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
998          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
999  );  );
# Line 958  sub root_handler { Line 1039  sub root_handler {
1039          my ($request, $response) = @_;          my ($request, $response) = @_;
1040          $response->code(RC_OK);          $response->code(RC_OK);
1041    
1042            # this doesn't seem to work, so moved to PreHandler
1043            #$response->header(Connection => 'close');
1044    
1045            return RC_OK if $request->uri =~ m/favicon.ico$/;
1046    
1047          my $q;          my $q;
1048    
1049          if ( $request->method eq 'POST' ) {          if ( $request->method eq 'POST' ) {
# Line 970  sub root_handler { Line 1056  sub root_handler {
1056    
1057          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1058    
1059          if ($request->url =~ m#/rss#i) {          if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1060                    my $show = lc($1);
1061                    my $nr = $2;
1062    
1063                  my $type = 'RSS';       # Atom                  my $type = 'RSS';       # Atom
1064    
1065                  $response->content_type( 'application/' . lc($type) . '+xml' );                  $response->content_type( 'application/' . lc($type) . '+xml' );
1066    
1067                  my $html = '<!-- error -->';                  my $html = '<!-- error -->';
1068                  warn "create $type feed from ",dump( @last_tags );                  #warn "create $type feed from ",dump( @last_tags );
1069    
1070                  my $feed = XML::Feed->new( $type );                  my $feed = XML::Feed->new( $type );
1071                    $feed->link( $url );
1072    
1073                  $feed->title( "last $last_x_tags from $CHANNEL" );                  if ( $show eq 'tags' ) {
1074  #               $feed->link( "http://$http_hostname:$http_port" );                          $nr ||= 50;
1075                  $feed->description( "collects messages which have tags// in them" );                          $feed->title( "tags from $CHANNEL" );
1076                            $feed->link( "$url/tags" );
1077                  foreach my $m ( @last_tags ) {                          $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
                         warn dump( $m );  
                         #my $tags = join(' ', @{$m->{tags}} );  
1078                          my $feed_entry = XML::Feed::Entry->new($type);                          my $feed_entry = XML::Feed::Entry->new($type);
1079                          $feed_entry->title( $m->{nick} . '@' . $m->{time} );                          $feed_entry->title( "$nr tags from $CHANNEL" );
1080                          $feed_entry->author( $m->{nick} );                          $feed_entry->author( $NICK );
1081  #                       $feed_entry->link(  );                          $feed_entry->link( '/#tags'  );
1082                          $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );  
1083                          $feed_entry->summary(                          $feed_entry->content(
1084                                  '<![CDATA[' .                                  qq{<![CDATA[<style type="text/css">}
1085  #                               $filter->{nick}->( $m->{nick} ) .                                  . $cloud->css
1086  #                               '<tt>' . $m->{nick} . '</tt> ' .                                  . qq{</style>}
1087                                  $filter->{message}->( $m->{message} ) .                                  . $cloud->html( $nr )
1088                                  ']]>'                                  . qq{]]>}
1089                          );                          );
                         $feed_entry->category( join(', ', @{$m->{tags}}) );  
1090                          $feed->add_entry( $feed_entry );                          $feed->add_entry( $feed_entry );
1091    
1092                    } elsif ( $show eq 'last-tag' ) {
1093    
1094                            $nr ||= $last_x_tags;
1095                            $nr = $last_x_tags if $nr > $last_x_tags;
1096    
1097                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1098                            $feed->description( "collects messages which have tags// in them" );
1099    
1100                            foreach my $m ( @last_tags ) {
1101    #                               warn dump( $m );
1102                                    #my $tags = join(' ', @{$m->{tags}} );
1103                                    my $feed_entry = XML::Feed::Entry->new($type);
1104                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1105                                    $feed_entry->author( $m->{nick} );
1106                                    $feed_entry->link( '/#' . $m->{id}  );
1107                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1108    
1109                                    my $message = $filter->{message}->( $m->{message} );
1110                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1111    #                               warn "## message = $message\n";
1112    
1113                                    #$feed_entry->summary(
1114                                    $feed_entry->content(
1115                                            "<![CDATA[$message]]>"
1116                                    );
1117                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1118                                    $feed->add_entry( $feed_entry );
1119    
1120                                    $nr--;
1121                                    last if $nr <= 0;
1122    
1123                            }
1124    
1125                    } elsif ( $show =~ m/^follow/ ) {
1126    
1127                            $feed->title( "Feeds which this bot follows" );
1128    
1129                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1130                            $sth->execute;
1131                            while (my $row = $sth->fetchrow_hashref) {
1132                                    my $feed_entry = XML::Feed::Entry->new($type);
1133                                    $feed_entry->title( $row->{name} );
1134                                    $feed_entry->link( $row->{url}  );
1135                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1136                                    $feed_entry->content(
1137                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1138                                    );
1139                                    $feed->add_entry( $feed_entry );
1140                            }
1141    
1142                    } else {
1143                            _log "unknown rss request ",$request->url;
1144                            return RC_DENY;
1145                  }                  }
1146    
1147                  $response->content( $feed->as_xml );                  $response->content( $feed->as_xml );
# Line 1011  sub root_handler { Line 1152  sub root_handler {
1152                  warn "$@";                  warn "$@";
1153          }          }
1154    
1155          $response->content_type("text/html; charset=$ENCODING");          $response->content_type("text/html; charset=UTF-8");
1156    
1157          my $html =          my $html =
1158                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1159                  $cloud->css .                  . $cloud->css
1160                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1161                  qq{                  . qq{
1162                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1163                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1164                  <input type="submit" value="search">                  <input type="submit" value="search">
1165                  </form>                  </form>
1166                  } .                  }
1167                  $cloud->html(500) .                  . $cloud->html(500)
1168                  qq{<p>};                  . qq{<p>};
1169          if ($request->url =~ m#/history#) {  
1170            if ($request->url =~ m#/tags?#) {
1171                    # nop
1172            } elsif ($request->url =~ m#/history#) {
1173                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1174                          select date(time) as date,count(*) as nr,sum(length(message)) as len                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1175                                  from log                                  from log
# Line 1057  sub root_handler { Line 1201  sub root_handler {
1201                                  $cal->weekdays('MON','TUE','WED','THU','FRI');                                  $cal->weekdays('MON','TUE','WED','THU','FRI');
1202                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1203                          }                          }
1204                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1205                                  <a href="/?date=$row->{date}">$row->{nr}</a><br/>$row->{len}                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1206                          });                          ]) if $cal;
1207                                                    
1208                  }                  }
1209                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
# Line 1074  sub root_handler { Line 1218  sub root_handler {
1218                                  fmt => {                                  fmt => {
1219                                          date => sub {                                          date => sub {
1220                                                  my $date = shift || return;                                                  my $date = shift || return;
1221                                                  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>};
1222                                          },                                          },
1223                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1224                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 1093  sub root_handler { Line 1237  sub root_handler {
1237          </body></html>};          </body></html>};
1238    
1239          $response->content( $html );          $response->content( $html );
1240            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1241          return RC_OK;          return RC_OK;
1242  }  }
1243    
Legend:
Removed from v.72  
changed lines
  Added in v.95
  ViewVC Help
Powered by ViewVC 1.1.26