/[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 68 by dpavlin, Sat Sep 29 14:11:55 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  ## END CONFIG  # number of last tags to keep in circular buffer
54    my $last_x_tags = 50;
55    
56    # 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  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  my $url = "http://$HOSTNAME:$http_port";
62    
63    ## END CONFIG
64    
65    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 77  use URI::Escape; Line 76  use URI::Escape;
76  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
77  use DateTime::Format::ISO8601;  use DateTime::Format::ISO8601;
78  use Carp qw/confess/;  use Carp qw/confess/;
79    use XML::Feed;
80    use DateTime::Format::Flexible;
81    
82  my $use_twitter = 1;  my $use_twitter = 1;
83  eval { require Net::Twitter; };  eval { require Net::Twitter; };
# Line 89  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
104    
105    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
106    my $escape_re  = join '|' => keys %escape;
107    
108    my $tag_regex = '\b([\w-_]+)//';
109    
110    my %nick_enumerator;
111    my $max_color = 0;
112    
113    my $filter = {
114            message => sub {
115                    my $m = shift || return;
116    
117                    # protect HTML from wiki modifications
118                    sub e {
119                            my $t = shift;
120                            return 'uri_unescape{' . uri_escape($t) . '}';
121                    }
122    
123                    $m =~ s/($escape_re)/$escape{$1}/gs;
124                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs ||
125                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
126                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
127                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
128                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
129    
130                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
131                    return $m;
132            },
133            nick => sub {
134                    my $n = shift || return;
135                    if (! $nick_enumerator{$n})  {
136                            my $max = scalar keys %nick_enumerator;
137                            $nick_enumerator{$n} = $max + 1;
138                    }
139                    return '<span class="nick col-' .
140                            ( $nick_enumerator{$n} % $max_color ) .
141                            '">' . $n . '</span>';
142            },
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 116  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 169  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 181  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 190  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 198  values (?,?,?,?,?) Line 256  values (?,?,?,?,?)
256    
257    
258  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
259    
260  =head2 get_from_log  =head2 get_from_log
261    
# Line 308  sub get_from_log { Line 365  sub get_from_log {
365          #warn "### sql: $sql ", dump( @args );          #warn "### sql: $sql ", dump( @args );
366    
367          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
368          $sth->execute( @args );          eval { $sth->execute( @args ) };
369            return if $@;
370    
371          my $last_row = {          my $last_row = {
372                  date => '',                  date => '',
# Line 430  my $cloud = HTML::TagCloud->new; Line 488  my $cloud = HTML::TagCloud->new;
488    
489  =head2 add_tag  =head2 add_tag
490    
491   add_tag( id => 42, message => 'irc message' );   add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
492    
493  =cut  =cut
494    
495    my @last_tags;
496    
497  sub add_tag {  sub add_tag {
498          my $arg = {@_};          my $arg = {@_};
499    
500          return unless ($arg->{id} && $arg->{message});          return unless ($arg->{id} && $arg->{message});
501    
502          my $m = $arg->{message};          my $m = $arg->{message};
503          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
504            my @tags;
505    
506          while ($m =~ s#$tag_regex##s) {          while ($m =~ s#$tag_regex##s) {
507                  my $tag = $1;                  my $tag = $1;
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;
513    
514          }          }
515    
516            if ( @tags ) {
517                    pop @last_tags if $#last_tags == $last_x_tags;
518                    unshift @last_tags, { tags => [ @tags ], %$arg };
519            }
520    
521  }  }
522    
523  =head2 seed_tags  =head2 seed_tags
# Line 458  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 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 478  seed_tags; Line 547  seed_tags;
547          channel => '#foobar',          channel => '#foobar',
548          me => 0,          me => 0,
549          nick => 'dpavlin',          nick => 'dpavlin',
550          msg => 'test message',          message => 'test message',
551          time => '2006-06-25 18:57:18',          time => '2006-06-25 18:57:18',
552    );    );
553    
# Line 490  C<me> if not specified will be C<0> (not Line 559  C<me> if not specified will be C<0> (not
559    
560  sub save_message {  sub save_message {
561          my $a = {@_};          my $a = {@_};
562            confess "have msg" if $a->{msg};
563          $a->{me} ||= 0;          $a->{me} ||= 0;
564          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
565    
566          _log          _log
567                  $a->{channel}, " ",                  $a->{channel}, " ",
568                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
569                  " " . $a->{msg};                  " " . $a->{message};
   
         from_to($a->{msg}, 'UTF-8', $ENCODING);  
570    
571          $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});          $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
572          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
                 message => $a->{msg});  
573  }  }
574    
575    
576  if ($import_dircproxy) {  if ($import_dircproxy) {
577          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
578          warn "importing $import_dircproxy...\n";          warn "importing $import_dircproxy...\n";
579          my $tz_offset = 2 * 60 * 60;    # TZ GMT+2          my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
580          while(<$l>) {          while(<$l>) {
581                  chomp;                  chomp;
582                  if (/^@(\d+)\s(\S+)\s(.+)$/) {                  if (/^@(\d+)\s(\S+)\s(.+)$/) {
# Line 527  if ($import_dircproxy) { Line 594  if ($import_dircproxy) {
594                                  channel => $CHANNEL,                                  channel => $CHANNEL,
595                                  me => $me,                                  me => $me,
596                                  nick => $nick,                                  nick => $nick,
597                                  msg => $msg,                                  message => $msg,
598                                  time => $dt->ymd . " " . $dt->hms,                                  time => $dt->ymd . " " . $dt->hms,
599                          ) if ($nick !~ m/^-/);                          ) if ($nick !~ m/^-/);
600    
# Line 540  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 569  POE::Session->create( inline_states => Line 738  POE::Session->create( inline_states =>
738                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
739                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
740    
741                  save_message( channel => $channel, me => 0, nick => $nick, msg => $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 578  POE::Session->create( inline_states => Line 748  POE::Session->create( inline_states =>
748                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
749                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
750    
751                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
752    
753                  if ( $use_twitter ) {                  if ( $use_twitter ) {
754                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
# Line 591  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 610  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 654  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 669  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 739  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 785  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    
988  # http server  # http server
989    
990  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
991          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          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  );  );
1000    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1001  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1002  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1003  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 880  hr { border: 1px dashed #ccc; height: 1p Line 1019  hr { border: 1px dashed #ccc; height: 1p
1019  .month { border: 0px; width: 100%; }  .month { border: 0px; width: 100%; }
1020  _END_OF_STYLE_  _END_OF_STYLE_
1021    
1022  my $max_color = 4;  $max_color = 0;
1023    
1024  my @cols = qw(  my @cols = qw(
1025          #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99          #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
# Line 890  my @cols = qw( Line 1029  my @cols = qw(
1029          #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff          #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1030  );  );
1031    
 $max_color = 0;  
1032  foreach my $c (@cols) {  foreach my $c (@cols) {
1033          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1034          $max_color++;          $max_color++;
1035  }  }
1036  warn "defined $max_color colors for users...\n";  warn "defined $max_color colors for users...\n";
1037    
 my %nick_enumerator;  
   
1038  sub root_handler {  sub root_handler {
1039          my ($request, $response) = @_;          my ($request, $response) = @_;
1040          $response->code(RC_OK);          $response->code(RC_OK);
1041          $response->content_type("text/html; charset=$ENCODING");  
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    
# Line 916  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(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1060                    my $show = lc($1);
1061                    my $nr = $2;
1062    
1063                    my $type = 'RSS';       # Atom
1064    
1065                    $response->content_type( 'application/' . lc($type) . '+xml' );
1066    
1067                    my $html = '<!-- error -->';
1068                    #warn "create $type feed from ",dump( @last_tags );
1069    
1070                    my $feed = XML::Feed->new( $type );
1071                    $feed->link( $url );
1072    
1073                    if ( $show eq 'tags' ) {
1074                            $nr ||= 50;
1075                            $feed->title( "tags from $CHANNEL" );
1076                            $feed->link( "$url/tags" );
1077                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1078                            my $feed_entry = XML::Feed::Entry->new($type);
1079                            $feed_entry->title( "$nr tags from $CHANNEL" );
1080                            $feed_entry->author( $NICK );
1081                            $feed_entry->link( '/#tags'  );
1082    
1083                            $feed_entry->content(
1084                                    qq{<![CDATA[<style type="text/css">}
1085                                    . $cloud->css
1086                                    . qq{</style>}
1087                                    . $cloud->html( $nr )
1088                                    . qq{]]>}
1089                            );
1090                            $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 );
1148                    return RC_OK;
1149            }
1150    
1151            if ( $@ ) {
1152                    warn "$@";
1153            }
1154    
1155            $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 960  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 977  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 985  sub root_handler { Line 1226  sub root_handler {
1226                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1227                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1228                                  },                                  },
1229                                  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>';  
                                         },  
                                 },  
1230                          )                          )
1231                  );                  );
1232          }          }
# Line 1026  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.68  
changed lines
  Added in v.95
  ViewVC Help
Powered by ViewVC 1.1.26