/[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 69 by dpavlin, Fri Dec 7 12:51:55 2007 UTC revision 89 by dpavlin, Fri Mar 7 00:43:45 2008 UTC
# Line 22  Import log from C<dircproxy> to C<irc-lo Line 22  Import log from C<dircproxy> to C<irc-lo
22    
23  Name of log file  Name of log file
24    
25    =item --follow=file.log
26    
27    Follows new messages in file
28    
29  =back  =back
30    
31  =head1 DESCRIPTION  =head1 DESCRIPTION
# Line 32  log all conversation on irc channel Line 36  log all conversation on irc channel
36    
37  ## CONFIG  ## CONFIG
38    
39  my $HOSTNAME = `hostname`;  my $HOSTNAME = `hostname -f`;
40    chomp($HOSTNAME);
41    
42  my $NICK = 'irc-logger';  my $NICK = 'irc-logger';
43  $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
# Line 45  my $CHANNEL = '#razmjenavjestina'; Line 50  my $CHANNEL = '#razmjenavjestina';
50  $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
51  my $IRC_ALIAS = "log";  my $IRC_ALIAS = "log";
52    
53  my %FOLLOWS =  # default log to follow and announce messages
54    (  my $follows_path = 'follows.log';
    ACCESS => "/var/log/apache/access.log",  
    ERROR => "/var/log/apache/error.log",  
   );  
55    
56  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
57    
 my $ENCODING = 'ISO-8859-2';  
58  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
59    
60  my $sleep_on_error = 5;  my $sleep_on_error = 5;
61    
62  ## END CONFIG  # number of last tags to keep in circular buffer
63    my $last_x_tags = 50;
64    
65    # don't pull rss feeds more often than this
66    my $rss_min_delay = 60;
67    $rss_min_delay = 15;
68    
69    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
70    
71    my $url = "http://$HOSTNAME:$http_port";
72    
73    ## END CONFIG
74    
75  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
76  use HTTP::Status;  use HTTP::Status;
77  use DBI;  use DBI;
 use Encode qw/from_to is_utf8/;  
78  use Regexp::Common qw /URI/;  use Regexp::Common qw /URI/;
79  use CGI::Simple;  use CGI::Simple;
80  use HTML::TagCloud;  use HTML::TagCloud;
# Line 77  use URI::Escape; Line 86  use URI::Escape;
86  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
87  use DateTime::Format::ISO8601;  use DateTime::Format::ISO8601;
88  use Carp qw/confess/;  use Carp qw/confess/;
89    use XML::Feed;
90    use DateTime::Format::Flexible;
91    
92  my $use_twitter = 1;  my $use_twitter = 1;
93  eval { require Net::Twitter; };  eval { require Net::Twitter; };
# Line 86  my $import_dircproxy; Line 97  my $import_dircproxy;
97  my $log_path;  my $log_path;
98  GetOptions(  GetOptions(
99          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
100            'follows:s' => \$follows_path,
101          'log:s' => \$log_path,          'log:s' => \$log_path,
102  );  );
103    
104  $SIG{__DIE__} = sub {  #$SIG{__DIE__} = sub {
105          confess "fatal error";  #       confess "fatal error";
106  };  #};
107    
108  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
109    
110  sub _log {  sub _log {
111          print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
112  }  }
113    
114    # LOG following
115    
116    my %FOLLOWS =
117      (
118    #   ACCESS => "/var/log/apache/access.log",
119    #   ERROR => "/var/log/apache/error.log",
120      );
121    
122    sub add_follow_path {
123            my $path = shift;
124            my $name = $path;
125            $name =~ s/\..*$//;
126            warn "# using $path to announce messages from $name\n";
127            $FOLLOWS{$name} = $path;
128    }
129    
130    add_follow_path( $follows_path ) if ( -e $follows_path );
131    
132    # HTML formatters
133    
134    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
135    my $escape_re  = join '|' => keys %escape;
136    
137    my $tag_regex = '\b([\w-_]+)//';
138    
139    my %nick_enumerator;
140    my $max_color = 0;
141    
142    my $filter = {
143            message => sub {
144                    my $m = shift || return;
145    
146                    # protect HTML from wiki modifications
147                    sub e {
148                            my $t = shift;
149                            return 'uri_unescape{' . uri_escape($t) . '}';
150                    }
151    
152                    $m =~ s/($escape_re)/$escape{$1}/gs;
153                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs ||
154                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
155                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
156                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
157                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
158    
159                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
160                    return $m;
161            },
162            nick => sub {
163                    my $n = shift || return;
164                    if (! $nick_enumerator{$n})  {
165                            my $max = scalar keys %nick_enumerator;
166                            $nick_enumerator{$n} = $max + 1;
167                    }
168                    return '<span class="nick col-' .
169                            ( $nick_enumerator{$n} % $max_color ) .
170                            '">' . $n . '</span>';
171            },
172    };
173    
174  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
175    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
176    
177  my $sql_schema = {  my $sql_schema = {
178          log => '          log => qq{
179  create table log (  create table log (
180          id serial,          id serial,
181          time timestamp default now(),          time timestamp default now(),
# Line 116  create table log ( Line 189  create table log (
189  create index log_time on log(time);  create index log_time on log(time);
190  create index log_channel on log(channel);  create index log_channel on log(channel);
191  create index log_nick on log(nick);  create index log_nick on log(nick);
192          ',          },
193          meta => '          meta => q{
194  create table meta (  create table meta (
195          nick text not null,          nick text not null,
196          channel text not null,          channel text not null,
197          name text not null,          name text not null,
198          value text,          value text,
199          changed timestamp default now(),          changed timestamp default 'now()',
200          primary key(nick,channel,name)          primary key(nick,channel,name)
201  );  );
202          ',          },
203            feeds => qq{
204    create table feeds (
205            id serial,
206            url text not null,
207            name text,
208            delay interval not null default '5 min',
209            active boolean default true,
210            last_update timestamp default 'now()',
211            polls int default 0,
212            updates int default 0
213    );
214    create unique index feeds_url on feeds(url);
215    insert into feeds (url,name) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki');
216            },
217  };  };
218    
219  foreach my $table ( keys %$sql_schema ) {  foreach my $table ( keys %$sql_schema ) {
# Line 190  sub meta { Line 277  sub meta {
277    
278    
279    
280  my $sth = $dbh->prepare(qq{  my $sth_insert_log = $dbh->prepare(qq{
281  insert into log  insert into log
282          (channel, me, nick, message, time)          (channel, me, nick, message, time)
283  values (?,?,?,?,?)  values (?,?,?,?,?)
# Line 198  values (?,?,?,?,?) Line 285  values (?,?,?,?,?)
285    
286    
287  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
288    
289  =head2 get_from_log  =head2 get_from_log
290    
# Line 431  my $cloud = HTML::TagCloud->new; Line 517  my $cloud = HTML::TagCloud->new;
517    
518  =head2 add_tag  =head2 add_tag
519    
520   add_tag( id => 42, message => 'irc message' );   add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
521    
522  =cut  =cut
523    
524    my @last_tags;
525    
526  sub add_tag {  sub add_tag {
527          my $arg = {@_};          my $arg = {@_};
528    
529          return unless ($arg->{id} && $arg->{message});          return unless ($arg->{id} && $arg->{message});
530    
531          my $m = $arg->{message};          my $m = $arg->{message};
532          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
533            my @tags;
534    
535          while ($m =~ s#$tag_regex##s) {          while ($m =~ s#$tag_regex##s) {
536                  my $tag = $1;                  my $tag = $1;
537                  next if (! $tag || $tag =~ m/https?:/i);                  next if (! $tag || $tag =~ m/https?:/i);
538                  push @{ $tags->{$tag} }, $arg->{id};                  push @{ $tags->{$tag} }, $arg->{id};
539                  #warn "+tag $tag: $arg->{id}\n";                  #warn "+tag $tag: $arg->{id}\n";
540                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
541                    push @tags, $tag;
542    
543          }          }
544    
545            if ( @tags ) {
546                    pop @last_tags if $#last_tags == $last_x_tags;
547                    unshift @last_tags, { tags => [ @tags ], %$arg };
548            }
549    
550  }  }
551    
552  =head2 seed_tags  =head2 seed_tags
# Line 459  Read all tags from database and create i Line 556  Read all tags from database and create i
556  =cut  =cut
557    
558  sub seed_tags {  sub seed_tags {
559          my $sth = $dbh->prepare(qq{ select id,message 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 });
560          $sth->execute;          $sth->execute;
561          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
562                  add_tag( %$row );                  add_tag( %$row );
563          }          }
564    
565          foreach my $tag (keys %$tags) {          foreach my $tag (keys %$tags) {
566                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
567          }          }
568  }  }
569    
# Line 479  seed_tags; Line 576  seed_tags;
576          channel => '#foobar',          channel => '#foobar',
577          me => 0,          me => 0,
578          nick => 'dpavlin',          nick => 'dpavlin',
579          msg => 'test message',          message => 'test message',
580          time => '2006-06-25 18:57:18',          time => '2006-06-25 18:57:18',
581    );    );
582    
# Line 491  C<me> if not specified will be C<0> (not Line 588  C<me> if not specified will be C<0> (not
588    
589  sub save_message {  sub save_message {
590          my $a = {@_};          my $a = {@_};
591            confess "have msg" if $a->{msg};
592          $a->{me} ||= 0;          $a->{me} ||= 0;
593          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
594    
595          _log          _log
596                  $a->{channel}, " ",                  $a->{channel}, " ",
597                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
598                  " " . $a->{msg};                  " " . $a->{message};
599    
600          from_to($a->{msg}, 'UTF-8', $ENCODING);          $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
601            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
         $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});  
         add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),  
                 message => $a->{msg});  
602  }  }
603    
604    
# Line 528  if ($import_dircproxy) { Line 623  if ($import_dircproxy) {
623                                  channel => $CHANNEL,                                  channel => $CHANNEL,
624                                  me => $me,                                  me => $me,
625                                  nick => $nick,                                  nick => $nick,
626                                  msg => $msg,                                  message => $msg,
627                                  time => $dt->ymd . " " . $dt->hms,                                  time => $dt->ymd . " " . $dt->hms,
628                          ) if ($nick !~ m/^-/);                          ) if ($nick !~ m/^-/);
629    
# Line 541  if ($import_dircproxy) { Line 636  if ($import_dircproxy) {
636          exit;          exit;
637  }  }
638    
639    #
640    # RSS follow
641    #
642    
643    my $_rss;
644    
645    
646    sub rss_fetch {
647            my ($args) = @_;
648    
649            # how many messages to send out when feed is seen for the first time?
650            my $send_rss_msgs = 1;
651    
652            _log "RSS fetch", $args->{url};
653    
654            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
655            if ( ! $feed ) {
656                    _log("can't fetch RSS ", $args->{url});
657                    return;
658            }
659            my ( $total, $updates ) = ( 0, 0 );
660            for my $entry ($feed->entries) {
661                    $total++;
662    
663                    # seen allready?
664                    return if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;
665    
666                    sub prefix {
667                            my ($txt,$var) = @_;
668                            $var =~ s/^\s+//g;
669                            return $txt . $var if $var;
670                    }
671    
672                    my $msg;
673                    $msg .= prefix( 'From: ' , $feed->title );
674                    $msg .= prefix( ' by ' , $entry->author );
675                    $msg .= prefix( ' -- ' , $entry->link );
676    #               $msg .= prefix( ' id ' , $entry->id );
677    
678                    if ( $args->{kernel} && $send_rss_msgs ) {
679                            $send_rss_msgs--;
680                            _log('RSS', $msg);
681                            $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, undef );
682                            $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );
683                            $updates++;
684                    }
685            }
686    
687            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
688            $sql .= qq{, updates = updates + $updates } if $updates;
689            $sql .= qq{where id = } . $args->{id};
690            eval { $dbh->do( $sql ) };
691    
692            _log "RSS got $total items of which $updates new";
693    
694            return $updates;
695    }
696    
697    sub rss_fetch_all {
698            my $kernel = shift;
699            my $sql = qq{
700                    select id, url, name
701                    from feeds
702                    where active is true
703            };
704            # limit to newer feeds only if we are not sending messages out
705            $sql .= qq{     and last_update + delay < now() } if $kernel;
706            my $sth = $dbh->prepare( $sql );
707            $sth->execute();
708            warn "# ",$sth->rows," active RSS feeds\n";
709            my $count = 0;
710            while (my $row = $sth->fetchrow_hashref) {
711                    $row->{kernel} = $kernel if $kernel;
712                    $count += rss_fetch( $row );
713            }
714            return "OK, fetched $count posts from " . $sth->rows . " feeds";
715    }
716    
717    
718    sub rss_check_updates {
719            my $kernel = shift;
720            my $last_t = $_rss->{last_poll} || time();
721            my $t = time();
722            if ( $last_t - $t > $rss_min_delay ) {
723                    $_rss->{last_poll} = $t;
724                    _log rss_fetch_all( $kernel );
725            }
726    }
727    
728    # seed rss seen cache so we won't send out all items on startup
729    _log rss_fetch_all;
730    
731  #  #
732  # POE handing part  # POE handing part
# Line 552  my $ping;                                              # ping stats Line 738  my $ping;                                              # ping stats
738    
739  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
740    
741  POE::Session->create( inline_states =>  POE::Session->create( inline_states => {
742     {_start => sub {                _start => sub {      
743                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
744                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
745      },      },
746      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
747                  $_[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;  
748                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
749      },      },
750      irc_public => sub {      irc_public => sub {
# Line 570  POE::Session->create( inline_states => Line 753  POE::Session->create( inline_states =>
753                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
754                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
755    
756                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
757                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
758      },      },
759      irc_ctcp_action => sub {      irc_ctcp_action => sub {
# Line 579  POE::Session->create( inline_states => Line 762  POE::Session->create( inline_states =>
762                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
763                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
764    
765                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
766    
767                  if ( $use_twitter ) {                  if ( $use_twitter ) {
768                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
# Line 592  POE::Session->create( inline_states => Line 775  POE::Session->create( inline_states =>
775    
776      },      },
777          irc_ping => sub {          irc_ping => sub {
778                  warn "pong ", $_[ARG0], $/;                  _log( "pong ", $_[ARG0] );
779                  $ping->{ $_[ARG0] }++;                  $ping->{ $_[ARG0] }++;
780                    rss_check_updates( $_[KERNEL] );
781          },          },
782          irc_invite => sub {          irc_invite => sub {
783                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
784                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
785                  my $channel = $_[ARG1];                  my $channel = $_[ARG1];
786    
787                  warn "invited to $channel by $nick";                  _log "invited to $channel by $nick";
788    
789                  $_[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..." );
790                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);
# Line 611  POE::Session->create( inline_states => Line 795  POE::Session->create( inline_states =>
795                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
796                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
797                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
                 from_to($msg, 'UTF-8', $ENCODING);  
798    
799                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
800                  my @out;                  my @out;
# Line 655  POE::Session->create( inline_states => Line 838  POE::Session->create( inline_states =>
838    
839                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
840                                  _log "last: $res";                                  _log "last: $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 670  POE::Session->create( inline_states => Line 852  POE::Session->create( inline_states =>
852                                          search => $what,                                          search => $what,
853                                  )) {                                  )) {
854                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
855                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
856                          }                          }
857    
# Line 740  POE::Session->create( inline_states => Line 921  POE::Session->create( inline_states =>
921                                          $res = "config option $op doesn't exist";                                          $res = "config option $op doesn't exist";
922                                  }                                  }
923                          }                          }
924                    } elsif ($msg =~ m/^rss-update/) {
925                            $res = rss_fetch_all( $_[KERNEL] );
926                    } elsif ($msg =~ m/^rss-clean/) {
927                            $_rss = undef;
928                            $res = "OK, cleaned RSS cache";
929                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {
930                            my $sql = {
931                                    add             => qq{ insert into feeds (url,name) values (?,?) },
932    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
933                                    start   => qq{ update feeds set active = true   where url = ? -- ? },
934                                    stop    => qq{ update feeds set active = false  where url = ? -- ? },
935                                    
936                            };
937                            if (my $q = $sql->{$1} ) {
938                                    my $sth = $dbh->prepare( $q );
939                                    warn "## SQL $q ( $2 | $3 )\n";
940                                    eval { $sth->execute( $2, $3 ) };
941                            }
942    
943                            $res ||= "OK, RSS $1 : $2 - $3";
944                  }                  }
945    
946                  if ($res) {                  if ($res) {
947                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
                         from_to($res, $ENCODING, 'UTF-8');  
948                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
949                  }                  }
950    
951                    rss_check_updates( $_[KERNEL] );
952          },          },
953          irc_477 => sub {          irc_477 => sub {
954                  _log "# irc_477: ",$_[ARG1];                  _log "# irc_477: ",$_[ARG1];
# Line 786  POE::Session->create( inline_states => Line 987  POE::Session->create( inline_states =>
987                          "";                          "";
988        0;                        # false for signals        0;                        # false for signals
989      },      },
     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);  
     }  
990     },     },
991    );    );
992    
993  # http server  # http server
994    
995  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
996          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
997            PreHandler => {
998                    '/' => sub {
999                            $_[0]->header(Connection => 'close')
1000                    }
1001            },
1002          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1003          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1004  );  );
1005    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1006  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1007  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1008  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 881  hr { border: 1px dashed #ccc; height: 1p Line 1024  hr { border: 1px dashed #ccc; height: 1p
1024  .month { border: 0px; width: 100%; }  .month { border: 0px; width: 100%; }
1025  _END_OF_STYLE_  _END_OF_STYLE_
1026    
1027  my $max_color = 4;  $max_color = 0;
1028    
1029  my @cols = qw(  my @cols = qw(
1030          #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99          #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
# Line 891  my @cols = qw( Line 1034  my @cols = qw(
1034          #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff          #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1035  );  );
1036    
 $max_color = 0;  
1037  foreach my $c (@cols) {  foreach my $c (@cols) {
1038          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1039          $max_color++;          $max_color++;
1040  }  }
1041  warn "defined $max_color colors for users...\n";  warn "defined $max_color colors for users...\n";
1042    
 my %nick_enumerator;  
   
1043  sub root_handler {  sub root_handler {
1044          my ($request, $response) = @_;          my ($request, $response) = @_;
1045          $response->code(RC_OK);          $response->code(RC_OK);
1046          $response->content_type("text/html; charset=$ENCODING");  
1047            # this doesn't seem to work, so moved to PreHandler
1048            #$response->header(Connection => 'close');
1049    
1050            return RC_OK if $request->uri =~ m/favicon.ico$/;
1051    
1052          my $q;          my $q;
1053    
# Line 917  sub root_handler { Line 1061  sub root_handler {
1061    
1062          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1063    
1064            if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1065                    my $show = lc($1);
1066                    my $nr = $2;
1067    
1068                    my $type = 'RSS';       # Atom
1069    
1070                    $response->content_type( 'application/' . lc($type) . '+xml' );
1071    
1072                    my $html = '<!-- error -->';
1073                    #warn "create $type feed from ",dump( @last_tags );
1074    
1075                    my $feed = XML::Feed->new( $type );
1076                    $feed->link( $url );
1077    
1078                    if ( $show eq 'tags' ) {
1079                            $nr ||= 50;
1080                            $feed->title( "tags from $CHANNEL" );
1081                            $feed->link( "$url/tags" );
1082                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1083                            my $feed_entry = XML::Feed::Entry->new($type);
1084                            $feed_entry->title( "$nr tags from $CHANNEL" );
1085                            $feed_entry->author( $NICK );
1086                            $feed_entry->link( '/#tags'  );
1087    
1088                            $feed_entry->content(
1089                                    qq{<![CDATA[<style type="text/css">}
1090                                    . $cloud->css
1091                                    . qq{</style>}
1092                                    . $cloud->html( $nr )
1093                                    . qq{]]>}
1094                            );
1095                            $feed->add_entry( $feed_entry );
1096    
1097                    } elsif ( $show eq 'last-tag' ) {
1098    
1099                            $nr ||= $last_x_tags;
1100                            $nr = $last_x_tags if $nr > $last_x_tags;
1101    
1102                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1103                            $feed->description( "collects messages which have tags// in them" );
1104    
1105                            foreach my $m ( @last_tags ) {
1106    #                               warn dump( $m );
1107                                    #my $tags = join(' ', @{$m->{tags}} );
1108                                    my $feed_entry = XML::Feed::Entry->new($type);
1109                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1110                                    $feed_entry->author( $m->{nick} );
1111                                    $feed_entry->link( '/#' . $m->{id}  );
1112                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1113    
1114                                    my $message = $filter->{message}->( $m->{message} );
1115                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1116    #                               warn "## message = $message\n";
1117    
1118                                    #$feed_entry->summary(
1119                                    $feed_entry->content(
1120                                            "<![CDATA[$message]]>"
1121                                    );
1122                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1123                                    $feed->add_entry( $feed_entry );
1124    
1125                                    $nr--;
1126                                    last if $nr <= 0;
1127    
1128                            }
1129    
1130                    } elsif ( $show =~ m/^follow/ ) {
1131    
1132                            $feed->title( "Feeds which this bot follows" );
1133    
1134                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1135                            $sth->execute;
1136                            while (my $row = $sth->fetchrow_hashref) {
1137                                    my $feed_entry = XML::Feed::Entry->new($type);
1138                                    $feed_entry->title( $row->{name} );
1139                                    $feed_entry->link( $row->{url}  );
1140                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1141                                    $feed_entry->content(
1142                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1143                                    );
1144                                    $feed->add_entry( $feed_entry );
1145                            }
1146    
1147                    } else {
1148                            _log "unknown rss request ",$request->url;
1149                            return RC_DENY;
1150                    }
1151    
1152                    $response->content( $feed->as_xml );
1153                    return RC_OK;
1154            }
1155    
1156            if ( $@ ) {
1157                    warn "$@";
1158            }
1159    
1160            $response->content_type("text/html; charset=UTF-8");
1161    
1162          my $html =          my $html =
1163                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1164                  $cloud->css .                  . $cloud->css
1165                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1166                  qq{                  . qq{
1167                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1168                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1169                  <input type="submit" value="search">                  <input type="submit" value="search">
1170                  </form>                  </form>
1171                  } .                  }
1172                  $cloud->html(500) .                  . $cloud->html(500)
1173                  qq{<p>};                  . qq{<p>};
1174          if ($request->url =~ m#/history#) {  
1175            if ($request->url =~ m#/tags?#) {
1176                    # nop
1177            } elsif ($request->url =~ m#/history#) {
1178                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1179                          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
1180                                  from log                                  from log
# Line 961  sub root_handler { Line 1206  sub root_handler {
1206                                  $cal->weekdays('MON','TUE','WED','THU','FRI');                                  $cal->weekdays('MON','TUE','WED','THU','FRI');
1207                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1208                          }                          }
1209                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1210                                  <a href="/?date=$row->{date}">$row->{nr}</a><br/>$row->{len}                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1211                          });                          ]) if $cal;
1212                                                    
1213                  }                  }
1214                  $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 978  sub root_handler { Line 1223  sub root_handler {
1223                                  fmt => {                                  fmt => {
1224                                          date => sub {                                          date => sub {
1225                                                  my $date = shift || return;                                                  my $date = shift || return;
1226                                                  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>};
1227                                          },                                          },
1228                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1229                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 986  sub root_handler { Line 1231  sub root_handler {
1231                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1232                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1233                                  },                                  },
1234                                  filter => {                                  filter => $filter,
                                         message => sub {  
                                                 my $m = shift || return;  
   
                                                 # protect HTML from wiki modifications  
                                                 sub e {  
                                                         my $t = shift;  
                                                         return 'uri_unescape{' . uri_escape($t) . '}';  
                                                 }  
   
                                                 $m =~ s/($escape_re)/$escape{$1}/gs;  
                                                 $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;  
                                                 $m =~ s#$tag_regex#e(qq{<a href="?tag=$1" class="tag">$1</a>})#egs;  
                                                 $m =~ s#\*(\w+)\*#<b>$1</b>#gs;  
                                                 $m =~ s#_(\w+)_#<u>$1</u>#gs;  
                                                 $m =~ s#\/(\w+)\/#<i>$1</i>#gs;  
   
                                                 $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;  
                                                 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>';  
                                         },  
                                 },  
1235                          )                          )
1236                  );                  );
1237          }          }
# Line 1027  sub root_handler { Line 1242  sub root_handler {
1242          </body></html>};          </body></html>};
1243    
1244          $response->content( $html );          $response->content( $html );
1245            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1246          return RC_OK;          return RC_OK;
1247  }  }
1248    
Legend:
Removed from v.69  
changed lines
  Added in v.89
  ViewVC Help
Powered by ViewVC 1.1.26