/[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 65 by dpavlin, Fri Jun 8 12:17:35 2007 UTC revision 91 by dpavlin, Fri Mar 7 10:13:45 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    $rss_min_delay = 15;
59    
60    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
61    
62    my $url = "http://$HOSTNAME:$http_port";
63    
64  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  ## END CONFIG
65    
66    use POE qw(Component::IRC Component::Server::HTTP);
67  use HTTP::Status;  use HTTP::Status;
68  use DBI;  use DBI;
 use Encode qw/from_to is_utf8/;  
69  use Regexp::Common qw /URI/;  use Regexp::Common qw /URI/;
70  use CGI::Simple;  use CGI::Simple;
71  use HTML::TagCloud;  use HTML::TagCloud;
# Line 76  use DateTime; Line 76  use DateTime;
76  use URI::Escape;  use URI::Escape;
77  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
78  use DateTime::Format::ISO8601;  use DateTime::Format::ISO8601;
79    use Carp qw/confess/;
80    use XML::Feed;
81    use DateTime::Format::Flexible;
82    
83  my $use_twitter = 1;  my $use_twitter = 1;
84  eval { require Net::Twitter; };  eval { require Net::Twitter; };
# Line 88  GetOptions( Line 91  GetOptions(
91          'log:s' => \$log_path,          'log:s' => \$log_path,
92  );  );
93    
94    #$SIG{__DIE__} = sub {
95    #       confess "fatal error";
96    #};
97    
98  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
99    
100  sub _log {  sub _log {
101          print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
102  }  }
103    
104    # HTML formatters
105    
106    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
107    my $escape_re  = join '|' => keys %escape;
108    
109    my $tag_regex = '\b([\w-_]+)//';
110    
111    my %nick_enumerator;
112    my $max_color = 0;
113    
114    my $filter = {
115            message => sub {
116                    my $m = shift || return;
117    
118                    # protect HTML from wiki modifications
119                    sub e {
120                            my $t = shift;
121                            return 'uri_unescape{' . uri_escape($t) . '}';
122                    }
123    
124                    $m =~ s/($escape_re)/$escape{$1}/gs;
125                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs ||
126                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
127                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
128                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
129                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
130    
131                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
132                    return $m;
133            },
134            nick => sub {
135                    my $n = shift || return;
136                    if (! $nick_enumerator{$n})  {
137                            my $max = scalar keys %nick_enumerator;
138                            $nick_enumerator{$n} = $max + 1;
139                    }
140                    return '<span class="nick col-' .
141                            ( $nick_enumerator{$n} % $max_color ) .
142                            '">' . $n . '</span>';
143            },
144    };
145    
146  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
147    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
148    
149  my $sql_schema = {  my $sql_schema = {
150          log => '          log => qq{
151  create table log (  create table log (
152          id serial,          id serial,
153          time timestamp default now(),          time timestamp default now(),
# Line 111  create table log ( Line 161  create table log (
161  create index log_time on log(time);  create index log_time on log(time);
162  create index log_channel on log(channel);  create index log_channel on log(channel);
163  create index log_nick on log(nick);  create index log_nick on log(nick);
164          ',          },
165          meta => '          meta => q{
166  create table meta (  create table meta (
167          nick text not null,          nick text not null,
168          channel text not null,          channel text not null,
169          name text not null,          name text not null,
170          value text,          value text,
171          changed timestamp default now(),          changed timestamp default 'now()',
172          primary key(nick,channel,name)          primary key(nick,channel,name)
173  );  );
174          ',          },
175            feeds => qq{
176    create table feeds (
177            id serial,
178            url text not null,
179            name text,
180            delay interval not null default '5 min',
181            active boolean default true,
182            last_update timestamp default 'now()',
183            polls int default 0,
184            updates int default 0
185    );
186    create unique index feeds_url on feeds(url);
187    insert into feeds (url,name) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki');
188            },
189  };  };
190    
191  foreach my $table ( keys %$sql_schema ) {  foreach my $table ( keys %$sql_schema ) {
# Line 185  sub meta { Line 249  sub meta {
249    
250    
251    
252  my $sth = $dbh->prepare(qq{  my $sth_insert_log = $dbh->prepare(qq{
253  insert into log  insert into log
254          (channel, me, nick, message, time)          (channel, me, nick, message, time)
255  values (?,?,?,?,?)  values (?,?,?,?,?)
# Line 193  values (?,?,?,?,?) Line 257  values (?,?,?,?,?)
257    
258    
259  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
260    
261  =head2 get_from_log  =head2 get_from_log
262    
# Line 230  C<me>, C<nick> and C<message> keys. Line 293  C<me>, C<nick> and C<message> keys.
293  sub get_from_log {  sub get_from_log {
294          my $args = {@_};          my $args = {@_};
295    
296          $args->{fmt} ||= {          if ( ! $args->{fmt} ) {
297                  date => '[%s] ',                  $args->{fmt} = {
298                  time => '{%s} ',                          date => '[%s] ',
299                  time_channel => '{%s %s} ',                          time => '{%s} ',
300                  nick => '%s: ',                          time_channel => '{%s %s} ',
301                  me_nick => '***%s ',                          nick => '%s: ',
302                  message => '%s',                          me_nick => '***%s ',
303          };                          message => '%s',
304                    };
305            }
306    
307          my $sql_message = qq{          my $sql_message = qq{
308                  select                  select
# Line 260  sub get_from_log { Line 325  sub get_from_log {
325    
326          my $sql = $context ? $sql_context : $sql_message;          my $sql = $context ? $sql_context : $sql_message;
327    
328          $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});          sub check_date {
329          $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });                  my $date = shift || return;
330          if ($args->{date}) {                  my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
                 my $date = eval { DateTime::Format::ISO8601->parse_datetime( $args->{date} )->ymd; };  
331                  if ( $@ ) {                  if ( $@ ) {
332                          warn "invalid date ", $args->{date}, $/;                          warn "invalid date $date\n";
333                          $date = DateTime->now->ymd;                          $new_date = DateTime->now->ymd;
334                  }                  }
335                  $sql .= " where date(time) = ? ";                  return $new_date;
                 $args->{date} = $date;  
336          }          }
         $sql .= " order by log.time desc";  
         $sql .= " limit " . $args->{limit} if ($args->{limit});  
337    
338          my $sth = $dbh->prepare( $sql );          my @where;
339            my @args;
340    
341          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
342                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
343                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
344                  $sth->execute( ( '%' . $search . '%' ) x 2 );                  push @where, 'message ilike ? or nick ilike ?';
345                  _log "search for '$search' returned ", $sth->rows, " results ", $context || '';                  push @args, ( ( '%' . $search . '%' ) x 2 );
346          } elsif (my $tag = $args->{tag}) {                  _log "search for '$search'";
                 $sth->execute();  
                 _log "tag '$tag' returned ", $sth->rows, " results ", $context || '';  
         } elsif (my $date = $args->{date}) {  
                 $sth->execute($date);  
                 _log "found ", $sth->rows, " messages for date $date ", $context || '';  
         } else {  
                 $sth->execute();  
347          }          }
348    
349            if ($args->{tag} && $tags->{ $args->{tag} }) {
350                    push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
351                    _log "search for tags $args->{tag}";
352            }
353    
354            if (my $date = $args->{date} ) {
355                    $date = check_date( $date );
356                    push @where, 'date(time) = ?';
357                    push @args, $date;
358                    _log "search for date $date";
359            }
360    
361            $sql .= " where " . join(" and ", @where) if @where;
362    
363            $sql .= " order by log.time desc";
364            $sql .= " limit " . $args->{limit} if ($args->{limit});
365    
366            #warn "### sql: $sql ", dump( @args );
367    
368            my $sth = $dbh->prepare( $sql );
369            eval { $sth->execute( @args ) };
370            return if $@;
371    
372          my $last_row = {          my $last_row = {
373                  date => '',                  date => '',
374                  time => '',                  time => '',
# Line 409  my $cloud = HTML::TagCloud->new; Line 489  my $cloud = HTML::TagCloud->new;
489    
490  =head2 add_tag  =head2 add_tag
491    
492   add_tag( id => 42, message => 'irc message' );   add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
493    
494  =cut  =cut
495    
496    my @last_tags;
497    
498  sub add_tag {  sub add_tag {
499          my $arg = {@_};          my $arg = {@_};
500    
501          return unless ($arg->{id} && $arg->{message});          return unless ($arg->{id} && $arg->{message});
502    
503          my $m = $arg->{message};          my $m = $arg->{message};
504          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
505            my @tags;
506    
507          while ($m =~ s#$tag_regex##s) {          while ($m =~ s#$tag_regex##s) {
508                  my $tag = $1;                  my $tag = $1;
509                  next if (! $tag || $tag =~ m/https?:/i);                  next if (! $tag || $tag =~ m/https?:/i);
510                  push @{ $tags->{$tag} }, $arg->{id};                  push @{ $tags->{$tag} }, $arg->{id};
511                  #warn "+tag $tag: $arg->{id}\n";                  #warn "+tag $tag: $arg->{id}\n";
512                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
513                    push @tags, $tag;
514    
515            }
516    
517            if ( @tags ) {
518                    pop @last_tags if $#last_tags == $last_x_tags;
519                    unshift @last_tags, { tags => [ @tags ], %$arg };
520          }          }
521    
522  }  }
523    
524  =head2 seed_tags  =head2 seed_tags
# Line 437  Read all tags from database and create i Line 528  Read all tags from database and create i
528  =cut  =cut
529    
530  sub seed_tags {  sub seed_tags {
531          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 });
532          $sth->execute;          $sth->execute;
533          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
534                  add_tag( %$row );                  add_tag( %$row );
535          }          }
536    
537          foreach my $tag (keys %$tags) {          foreach my $tag (keys %$tags) {
538                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
539          }          }
540  }  }
541    
# Line 457  seed_tags; Line 548  seed_tags;
548          channel => '#foobar',          channel => '#foobar',
549          me => 0,          me => 0,
550          nick => 'dpavlin',          nick => 'dpavlin',
551          msg => 'test message',          message => 'test message',
552          time => '2006-06-25 18:57:18',          time => '2006-06-25 18:57:18',
553    );    );
554    
# Line 469  C<me> if not specified will be C<0> (not Line 560  C<me> if not specified will be C<0> (not
560    
561  sub save_message {  sub save_message {
562          my $a = {@_};          my $a = {@_};
563            confess "have msg" if $a->{msg};
564          $a->{me} ||= 0;          $a->{me} ||= 0;
565          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
566    
567          _log          _log
568                  $a->{channel}, " ",                  $a->{channel}, " ",
569                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
570                  " " . $a->{msg};                  " " . $a->{message};
571    
572          from_to($a->{msg}, 'UTF-8', $ENCODING);          $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
573            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});  
574  }  }
575    
576    
577  if ($import_dircproxy) {  if ($import_dircproxy) {
578          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
579          warn "importing $import_dircproxy...\n";          warn "importing $import_dircproxy...\n";
580          my $tz_offset = 2 * 60 * 60;    # TZ GMT+2          my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
581          while(<$l>) {          while(<$l>) {
582                  chomp;                  chomp;
583                  if (/^@(\d+)\s(\S+)\s(.+)$/) {                  if (/^@(\d+)\s(\S+)\s(.+)$/) {
# Line 506  if ($import_dircproxy) { Line 595  if ($import_dircproxy) {
595                                  channel => $CHANNEL,                                  channel => $CHANNEL,
596                                  me => $me,                                  me => $me,
597                                  nick => $nick,                                  nick => $nick,
598                                  msg => $msg,                                  message => $msg,
599                                  time => $dt->ymd . " " . $dt->hms,                                  time => $dt->ymd . " " . $dt->hms,
600                          ) if ($nick !~ m/^-/);                          ) if ($nick !~ m/^-/);
601    
# Line 519  if ($import_dircproxy) { Line 608  if ($import_dircproxy) {
608          exit;          exit;
609  }  }
610    
611    #
612    # RSS follow
613    #
614    
615    my $_rss;
616    
617    
618    sub rss_fetch {
619            my ($args) = @_;
620    
621            # how many messages to send out when feed is seen for the first time?
622            my $send_rss_msgs = 1;
623    
624            _log "RSS fetch", $args->{url};
625    
626            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
627            if ( ! $feed ) {
628                    _log("can't fetch RSS ", $args->{url});
629                    return;
630            }
631            my ( $total, $updates ) = ( 0, 0 );
632            for my $entry ($feed->entries) {
633                    $total++;
634    
635                    # seen allready?
636                    return if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;
637    
638                    sub prefix {
639                            my ($txt,$var) = @_;
640                            $var =~ s/^\s+//g;
641                            return $txt . $var if $var;
642                    }
643    
644                    my $msg;
645                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
646                    $msg .= prefix( ' by ' , $entry->author );
647                    $msg .= prefix( ' -- ' , $entry->link );
648    #               $msg .= prefix( ' id ' , $entry->id );
649    
650                    if ( $args->{kernel} && $send_rss_msgs ) {
651                            $send_rss_msgs--;
652                            _log('RSS', $msg);
653                            $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, undef );
654                            $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );
655                            $updates++;
656                    }
657            }
658    
659            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
660            $sql .= qq{, updates = updates + $updates } if $updates;
661            $sql .= qq{where id = } . $args->{id};
662            eval { $dbh->do( $sql ) };
663    
664            _log "RSS got $total items of which $updates new";
665    
666            return $updates;
667    }
668    
669    sub rss_fetch_all {
670            my $kernel = shift;
671            my $sql = qq{
672                    select id, url, name
673                    from feeds
674                    where active is true
675            };
676            # limit to newer feeds only if we are not sending messages out
677            $sql .= qq{     and last_update + delay < now() } if $kernel;
678            my $sth = $dbh->prepare( $sql );
679            $sth->execute();
680            warn "# ",$sth->rows," active RSS feeds\n";
681            my $count = 0;
682            while (my $row = $sth->fetchrow_hashref) {
683                    $row->{kernel} = $kernel if $kernel;
684                    $count += rss_fetch( $row );
685            }
686            return "OK, fetched $count posts from " . $sth->rows . " feeds";
687    }
688    
689    
690    sub rss_check_updates {
691            my $kernel = shift;
692            my $last_t = $_rss->{last_poll} || time();
693            my $t = time();
694            if ( $t - $last_t > $rss_min_delay ) {
695                    $_rss->{last_poll} = $t;
696                    _log rss_fetch_all( $kernel );
697            }
698    }
699    
700    # seed rss seen cache so we won't send out all items on startup
701    _log rss_fetch_all;
702    
703  #  #
704  # POE handing part  # POE handing part
705  #  #
706    
 my $SKIPPING = 0;               # if skipping, how many we've done  
 my $SEND_QUEUE;                 # cache  
707  my $ping;                                               # ping stats  my $ping;                                               # ping stats
708    
709  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
710    
711  POE::Session->create( inline_states =>  POE::Session->create( inline_states => {
712     {_start => sub {                _start => sub {      
713                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
714                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
715      },      },
716      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
717                  $_[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;  
718                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
719      },      },
720      irc_public => sub {      irc_public => sub {
# Line 548  POE::Session->create( inline_states => Line 723  POE::Session->create( inline_states =>
723                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
724                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
725    
726                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
727                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
728      },      },
729      irc_ctcp_action => sub {      irc_ctcp_action => sub {
# Line 557  POE::Session->create( inline_states => Line 732  POE::Session->create( inline_states =>
732                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
733                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
734    
735                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
736    
737                  if ( $use_twitter ) {                  if ( $use_twitter ) {
738                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
# Line 570  POE::Session->create( inline_states => Line 745  POE::Session->create( inline_states =>
745    
746      },      },
747          irc_ping => sub {          irc_ping => sub {
748                  warn "pong ", $_[ARG0], $/;                  _log( "pong ", $_[ARG0] );
749                  $ping->{ $_[ARG0] }++;                  $ping->{ $_[ARG0] }++;
750                    rss_check_updates( $_[KERNEL] );
751          },          },
752          irc_invite => sub {          irc_invite => sub {
753                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
754                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
755                  my $channel = $_[ARG1];                  my $channel = $_[ARG1];
756    
757                  warn "invited to $channel by $nick";                  _log "invited to $channel by $nick";
758    
759                  $_[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..." );
760                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);
# Line 589  POE::Session->create( inline_states => Line 765  POE::Session->create( inline_states =>
765                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
766                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
767                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
                 from_to($msg, 'UTF-8', $ENCODING);  
768    
769                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
770                  my @out;                  my @out;
# Line 633  POE::Session->create( inline_states => Line 808  POE::Session->create( inline_states =>
808    
809                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
810                                  _log "last: $res";                                  _log "last: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
811                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
812                          }                          }
813    
# Line 648  POE::Session->create( inline_states => Line 822  POE::Session->create( inline_states =>
822                                          search => $what,                                          search => $what,
823                                  )) {                                  )) {
824                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
825                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
826                          }                          }
827    
# Line 718  POE::Session->create( inline_states => Line 891  POE::Session->create( inline_states =>
891                                          $res = "config option $op doesn't exist";                                          $res = "config option $op doesn't exist";
892                                  }                                  }
893                          }                          }
894                    } elsif ($msg =~ m/^rss-update/) {
895                            $res = rss_fetch_all( $_[KERNEL] );
896                    } elsif ($msg =~ m/^rss-clean/) {
897                            $_rss = undef;
898                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
899                            $res = "OK, cleaned RSS cache";
900                    } elsif ($msg =~ m/^rss-list/) {
901                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active from feeds });
902                            $sth->execute;
903                            while (my @row = $sth->fetchrow_array) {
904                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
905                            }
906                            $res = '';
907                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {
908                            my $sql = {
909                                    add             => qq{ insert into feeds (url,name) values (?,?) },
910    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
911                                    start   => qq{ update feeds set active = true   where url = ? },
912                                    stop    => qq{ update feeds set active = false  where url = ? },
913                                    
914                            };
915                            if (my $q = $sql->{$1} ) {
916                                    my $sth = $dbh->prepare( $q );
917                                    my @data = ( $2 );
918                                    push @data, $3 if ( $q =~ s/\?//g == 2 );
919                                    warn "## $1 SQL $q with ",dump( @data ),"\n";
920                                    eval { $sth->execute( @data ) };
921                            }
922    
923                            $res = "OK, RSS $1 : $2 - $3";
924                  }                  }
925    
926                  if ($res) {                  if ($res) {
927                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
                         from_to($res, $ENCODING, 'UTF-8');  
928                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
929                  }                  }
930    
931                    rss_check_updates( $_[KERNEL] );
932          },          },
933          irc_477 => sub {          irc_477 => sub {
934                  _log "# irc_477: ",$_[ARG1];                  _log "# irc_477: ",$_[ARG1];
# Line 764  POE::Session->create( inline_states => Line 967  POE::Session->create( inline_states =>
967                          "";                          "";
968        0;                        # false for signals        0;                        # false for signals
969      },      },
     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);  
     }  
970     },     },
971    );    );
972    
973  # http server  # http server
974    
975  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
976          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
977            PreHandler => {
978                    '/' => sub {
979                            $_[0]->header(Connection => 'close')
980                    }
981            },
982          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
983          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
984  );  );
985    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
986  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
987  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
988  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 859  hr { border: 1px dashed #ccc; height: 1p Line 1004  hr { border: 1px dashed #ccc; height: 1p
1004  .month { border: 0px; width: 100%; }  .month { border: 0px; width: 100%; }
1005  _END_OF_STYLE_  _END_OF_STYLE_
1006    
1007  my $max_color = 4;  $max_color = 0;
1008    
1009  my @cols = qw(  my @cols = qw(
1010          #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99          #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
# Line 869  my @cols = qw( Line 1014  my @cols = qw(
1014          #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff          #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1015  );  );
1016    
 $max_color = 0;  
1017  foreach my $c (@cols) {  foreach my $c (@cols) {
1018          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1019          $max_color++;          $max_color++;
1020  }  }
1021  warn "defined $max_color colors for users...\n";  warn "defined $max_color colors for users...\n";
1022    
 my %nick_enumerator;  
   
1023  sub root_handler {  sub root_handler {
1024          my ($request, $response) = @_;          my ($request, $response) = @_;
1025          $response->code(RC_OK);          $response->code(RC_OK);
1026          $response->content_type("text/html; charset=$ENCODING");  
1027            # this doesn't seem to work, so moved to PreHandler
1028            #$response->header(Connection => 'close');
1029    
1030            return RC_OK if $request->uri =~ m/favicon.ico$/;
1031    
1032          my $q;          my $q;
1033    
# Line 895  sub root_handler { Line 1041  sub root_handler {
1041    
1042          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1043    
1044            if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1045                    my $show = lc($1);
1046                    my $nr = $2;
1047    
1048                    my $type = 'RSS';       # Atom
1049    
1050                    $response->content_type( 'application/' . lc($type) . '+xml' );
1051    
1052                    my $html = '<!-- error -->';
1053                    #warn "create $type feed from ",dump( @last_tags );
1054    
1055                    my $feed = XML::Feed->new( $type );
1056                    $feed->link( $url );
1057    
1058                    if ( $show eq 'tags' ) {
1059                            $nr ||= 50;
1060                            $feed->title( "tags from $CHANNEL" );
1061                            $feed->link( "$url/tags" );
1062                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1063                            my $feed_entry = XML::Feed::Entry->new($type);
1064                            $feed_entry->title( "$nr tags from $CHANNEL" );
1065                            $feed_entry->author( $NICK );
1066                            $feed_entry->link( '/#tags'  );
1067    
1068                            $feed_entry->content(
1069                                    qq{<![CDATA[<style type="text/css">}
1070                                    . $cloud->css
1071                                    . qq{</style>}
1072                                    . $cloud->html( $nr )
1073                                    . qq{]]>}
1074                            );
1075                            $feed->add_entry( $feed_entry );
1076    
1077                    } elsif ( $show eq 'last-tag' ) {
1078    
1079                            $nr ||= $last_x_tags;
1080                            $nr = $last_x_tags if $nr > $last_x_tags;
1081    
1082                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1083                            $feed->description( "collects messages which have tags// in them" );
1084    
1085                            foreach my $m ( @last_tags ) {
1086    #                               warn dump( $m );
1087                                    #my $tags = join(' ', @{$m->{tags}} );
1088                                    my $feed_entry = XML::Feed::Entry->new($type);
1089                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1090                                    $feed_entry->author( $m->{nick} );
1091                                    $feed_entry->link( '/#' . $m->{id}  );
1092                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1093    
1094                                    my $message = $filter->{message}->( $m->{message} );
1095                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1096    #                               warn "## message = $message\n";
1097    
1098                                    #$feed_entry->summary(
1099                                    $feed_entry->content(
1100                                            "<![CDATA[$message]]>"
1101                                    );
1102                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1103                                    $feed->add_entry( $feed_entry );
1104    
1105                                    $nr--;
1106                                    last if $nr <= 0;
1107    
1108                            }
1109    
1110                    } elsif ( $show =~ m/^follow/ ) {
1111    
1112                            $feed->title( "Feeds which this bot follows" );
1113    
1114                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1115                            $sth->execute;
1116                            while (my $row = $sth->fetchrow_hashref) {
1117                                    my $feed_entry = XML::Feed::Entry->new($type);
1118                                    $feed_entry->title( $row->{name} );
1119                                    $feed_entry->link( $row->{url}  );
1120                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1121                                    $feed_entry->content(
1122                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1123                                    );
1124                                    $feed->add_entry( $feed_entry );
1125                            }
1126    
1127                    } else {
1128                            _log "unknown rss request ",$request->url;
1129                            return RC_DENY;
1130                    }
1131    
1132                    $response->content( $feed->as_xml );
1133                    return RC_OK;
1134            }
1135    
1136            if ( $@ ) {
1137                    warn "$@";
1138            }
1139    
1140            $response->content_type("text/html; charset=UTF-8");
1141    
1142          my $html =          my $html =
1143                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1144                  $cloud->css .                  . $cloud->css
1145                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1146                  qq{                  . qq{
1147                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1148                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1149                  <input type="submit" value="search">                  <input type="submit" value="search">
1150                  </form>                  </form>
1151                  } .                  }
1152                  $cloud->html(500) .                  . $cloud->html(500)
1153                  qq{<p>};                  . qq{<p>};
1154          if ($request->url =~ m#/history#) {  
1155            if ($request->url =~ m#/tags?#) {
1156                    # nop
1157            } elsif ($request->url =~ m#/history#) {
1158                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1159                          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
1160                                  from log                                  from log
# Line 939  sub root_handler { Line 1186  sub root_handler {
1186                                  $cal->weekdays('MON','TUE','WED','THU','FRI');                                  $cal->weekdays('MON','TUE','WED','THU','FRI');
1187                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1188                          }                          }
1189                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1190                                  <a href="/?date=$row->{date}">$row->{nr}</a><br/>$row->{len}                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1191                          });                          ]) if $cal;
1192                                                    
1193                  }                  }
1194                  $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 949  sub root_handler { Line 1196  sub root_handler {
1196          } else {          } else {
1197                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1198                          get_from_log(                          get_from_log(
1199                                  limit => $q->param('last') || $q->param('date') ? undef : 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1200                                  search => $search || undef,                                  search => $search || undef,
1201                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1202                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
1203                                  fmt => {                                  fmt => {
1204                                          date => sub {                                          date => sub {
1205                                                  my $date = shift || return;                                                  my $date = shift || return;
1206                                                  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>};
1207                                          },                                          },
1208                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1209                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 964  sub root_handler { Line 1211  sub root_handler {
1211                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1212                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1213                                  },                                  },
1214                                  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>';  
                                         },  
                                 },  
1215                          )                          )
1216                  );                  );
1217          }          }
# Line 1005  sub root_handler { Line 1222  sub root_handler {
1222          </body></html>};          </body></html>};
1223    
1224          $response->content( $html );          $response->content( $html );
1225            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1226          return RC_OK;          return RC_OK;
1227  }  }
1228    
Legend:
Removed from v.65  
changed lines
  Added in v.91
  ViewVC Help
Powered by ViewVC 1.1.26