/[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 83 by dpavlin, Fri Feb 29 22:11:07 2008 UTC revision 120 by dpavlin, Fri Mar 14 13:37:45 2008 UTC
# Line 2  Line 2 
2  use strict;  use strict;
3  $|++;  $|++;
4    
5    use POE qw(Component::IRC Component::Server::HTTP);
6    use HTTP::Status;
7    use DBI;
8    use Regexp::Common qw /URI/;
9    use CGI::Simple;
10    use HTML::TagCloud;
11    use POSIX qw/strftime/;
12    use HTML::CalendarMonthSimple;
13    use Getopt::Long;
14    use DateTime;
15    use URI::Escape;
16    use Data::Dump qw/dump/;
17    use DateTime::Format::ISO8601;
18    use Carp qw/confess/;
19    use XML::Feed;
20    use DateTime::Format::Flexible;
21    use IPC::DirQueue;
22    use File::Slurp;
23    
24  =head1 NAME  =head1 NAME
25    
26  irc-logger.pl  irc-logger.pl
# Line 20  Import log from C<dircproxy> to C<irc-lo Line 39  Import log from C<dircproxy> to C<irc-lo
39    
40  =item --log=irc-logger.log  =item --log=irc-logger.log
41    
 Name of log file  
   
42  =back  =back
43    
44  =head1 DESCRIPTION  =head1 DESCRIPTION
# Line 32  log all conversation on irc channel Line 49  log all conversation on irc channel
49    
50  ## CONFIG  ## CONFIG
51    
52    my $debug = 0;
53    
54    my $irc_config = {
55            nick => 'irc-logger',
56            server => 'irc.freenode.net',
57            port => 6667,
58            ircname => 'Anna the bot: try /msg irc-logger help',
59    };
60    
61    my $queue_dir = './queue';
62    
63  my $HOSTNAME = `hostname -f`;  my $HOSTNAME = `hostname -f`;
64  chomp($HOSTNAME);  chomp($HOSTNAME);
65    
66  my $NICK = 'irc-logger';  
 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  
 my $CONNECT =  
   {Server => 'irc.freenode.net',  
    Nick => $NICK,  
    Ircname => "try /msg $NICK help",  
   };  
67  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
 $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  
 my $IRC_ALIAS = "log";  
68    
69  my %FOLLOWS =  if ( $HOSTNAME =~ m/llin/ ) {
70    (          $irc_config->{nick} = 'irc-logger-llin';
71     ACCESS => "/var/log/apache/access.log",  #       $irc_config = {
72     ERROR => "/var/log/apache/error.log",  #               nick => 'irc-logger-llin',
73    );  #               server => 'localhost',
74    #               port => 6668,
75    #       };
76            $CHANNEL = '#irc-logger';
77    } elsif ( $HOSTNAME =~ m/lugarin/ ) {
78            $irc_config->{server} = 'irc.carnet.hr';
79            $CHANNEL = '#riss';
80    }
81    
82    my @channels = ( $CHANNEL );
83    
84    warn "# config = ", dump( $irc_config ), $/;
85    
86    my $NICK = $irc_config->{nick} or die "no nick?";
87    
88  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
89    
 my $ENCODING = 'ISO-8859-2';  
90  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
91    
92  my $sleep_on_error = 5;  my $sleep_on_error = 5;
# Line 62  my $sleep_on_error = 5; Line 94  my $sleep_on_error = 5;
94  # number of last tags to keep in circular buffer  # number of last tags to keep in circular buffer
95  my $last_x_tags = 50;  my $last_x_tags = 50;
96    
97    # don't pull rss feeds more often than this
98    my $rss_min_delay = 60;
99    
100  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
101    
102  my $url = "http://$HOSTNAME:$http_port";  my $url = "http://$HOSTNAME:$http_port";
103    
104  ## END CONFIG  ## END CONFIG
105    
   
   
 use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  
 use HTTP::Status;  
 use DBI;  
 use Encode qw/from_to is_utf8/;  
 use Regexp::Common qw /URI/;  
 use CGI::Simple;  
 use HTML::TagCloud;  
 use POSIX qw/strftime/;  
 use HTML::CalendarMonthSimple;  
 use Getopt::Long;  
 use DateTime;  
 use URI::Escape;  
 use Data::Dump qw/dump/;  
 use DateTime::Format::ISO8601;  
 use Carp qw/confess/;  
 use XML::Feed;  
 use DateTime::Format::Flexible;  
   
106  my $use_twitter = 1;  my $use_twitter = 1;
107  eval { require Net::Twitter; };  eval { require Net::Twitter; };
108  $use_twitter = 0 if ($@);  $use_twitter = 0 if ($@);
# Line 97  my $log_path; Line 112  my $log_path;
112  GetOptions(  GetOptions(
113          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
114          'log:s' => \$log_path,          'log:s' => \$log_path,
115            'queue:s' => \$queue_dir,
116  );  );
117    
118  $SIG{__DIE__} = sub {  #$SIG{__DIE__} = sub {
119          confess "fatal error";  #       confess "fatal error";
120  };  #};
   
 open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  
121    
122  sub _log {  sub _log {
123          print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
124    }
125    
126    open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
127    
128    # queue
129    
130    if ( ! -d $queue_dir ) {
131            warn "## creating queue directory $queue_dir";
132            mkdir $queue_dir or die "can't create queue directory $queue_dir: $!";
133  }  }
134    
135    my $dq = IPC::DirQueue->new({ dir => $queue_dir });
136    
137  # HTML formatters  # HTML formatters
138    
139  my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
# Line 126  my $filter = { Line 151  my $filter = {
151                  # protect HTML from wiki modifications                  # protect HTML from wiki modifications
152                  sub e {                  sub e {
153                          my $t = shift;                          my $t = shift;
154                          return 'uri_unescape{' . uri_escape($t) . '}';                          return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
155                  }                  }
156    
157                  $m =~ s/($escape_re)/$escape{$1}/gs;                  $m =~ s/($escape_re)/$escape{$1}/gs;
158                  $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs ||                  $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
159                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
160                  $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;                  $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
161                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
# Line 151  my $filter = { Line 176  my $filter = {
176          },          },
177  };  };
178    
179    # POE IRC
180    my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
181            die "can't start ", dump( $irc_config ), ": $!";
182    
183    my $irc = $poe_irc->session_id();
184    _log "IRC session_id $irc";
185    
186  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
187    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
188    
189  my $sql_schema = {  my $sql_schema = {
190          log => '          log => qq{
191  create table log (  create table log (
192          id serial,          id serial,
193          time timestamp default now(),          time timestamp default now(),
# Line 168  create table log ( Line 201  create table log (
201  create index log_time on log(time);  create index log_time on log(time);
202  create index log_channel on log(channel);  create index log_channel on log(channel);
203  create index log_nick on log(nick);  create index log_nick on log(nick);
204          ',          },
205          meta => '          meta => q{
206  create table meta (  create table meta (
207          nick text not null,          nick text not null,
208          channel text not null,          channel text not null,
209          name text not null,          name text not null,
210          value text,          value text,
211          changed timestamp default now(),          changed timestamp default 'now()',
212          primary key(nick,channel,name)          primary key(nick,channel,name)
213  );  );
214          ',          },
215            feeds => qq{
216    create table feeds (
217            id serial,
218            url text not null,
219            name text,
220            delay interval not null default '5 min',
221            active boolean default true,
222            channel text not null,
223            nick text not null,
224            private boolean default false,
225            last_update timestamp default 'now()',
226            polls int default 0,
227            updates int default 0
228    );
229    create unique index feeds_url on feeds(url);
230    insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
231            },
232  };  };
233    
234  foreach my $table ( keys %$sql_schema ) {  foreach my $table ( keys %$sql_schema ) {
# Line 221  sub meta { Line 271  sub meta {
271                  if ( $@ || ! $sth->rows ) {                  if ( $@ || ! $sth->rows ) {
272                          $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()) });
273                          $sth->execute( $value, $nick, $channel, $name );                          $sth->execute( $value, $nick, $channel, $name );
274                          _log "created $nick/$channel/$name = $value";                          warn "## created $nick/$channel/$name = $value\n";
275                  } else {                  } else {
276                          _log "updated $nick/$channel/$name = $value ";                          warn "## updated $nick/$channel/$name = $value\n";
277                  }                  }
278    
279                  return $value;                  return $value;
# Line 233  sub meta { Line 283  sub meta {
283                  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 = ? });
284                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
285                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
286                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
287                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
288                  return $v;                  return $v;
289    
# Line 242  sub meta { Line 292  sub meta {
292    
293    
294    
295  my $sth = $dbh->prepare(qq{  my $sth_insert_log = $dbh->prepare(qq{
296  insert into log  insert into log
297          (channel, me, nick, message, time)          (channel, me, nick, message, time)
298  values (?,?,?,?,?)  values (?,?,?,?,?)
# Line 330  sub get_from_log { Line 380  sub get_from_log {
380    
381          my @where;          my @where;
382          my @args;          my @args;
383            my $msg;
384    
385          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
386                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
387                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
388                  push @where, 'message ilike ? or nick ilike ?';                  push @where, 'message ilike ? or nick ilike ?';
389                  push @args, ( ( '%' . $search . '%' ) x 2 );                  push @args, ( ( '%' . $search . '%' ) x 2 );
390                  _log "search for '$search'";                  $msg = "Search for '$search'";
391          }          }
392    
393          if ($args->{tag} && $tags->{ $args->{tag} }) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
394                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
395                  _log "search for tags $args->{tag}";                  $msg = "Search for tags $args->{tag}";
396          }          }
397    
398          if (my $date = $args->{date} ) {          if (my $date = $args->{date} ) {
399                  $date = check_date( $date );                  $date = check_date( $date );
400                  push @where, 'date(time) = ?';                  push @where, 'date(time) = ?';
401                  push @args, $date;                  push @args, $date;
402                  _log "search for date $date";                  $msg = "search for date $date";
403          }          }
404    
405          $sql .= " where " . join(" and ", @where) if @where;          $sql .= " where " . join(" and ", @where) if @where;
# Line 362  sub get_from_log { Line 413  sub get_from_log {
413          eval { $sth->execute( @args ) };          eval { $sth->execute( @args ) };
414          return if $@;          return if $@;
415    
416            my $nr_results = $sth->rows;
417    
418          my $last_row = {          my $last_row = {
419                  date => '',                  date => '',
420                  time => '',                  time => '',
# Line 382  sub get_from_log { Line 435  sub get_from_log {
435    
436          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
437    
438          my @msgs = (          $msg .= ' produced ' . (
439                  "Showing " . ($#rows + 1) . " messages..."                  $nr_results == 0 ? 'no results' :
440                    $nr_results == 0 ? 'one result' :
441                            $nr_results . ' results'
442          );          );
443    
444            my @msgs = ( $msg );
445    
446          if ($context) {          if ($context) {
447                  my @ids = @rows;                  my @ids = @rows;
448                  @rows = ();                  @rows = ();
# Line 442  sub get_from_log { Line 499  sub get_from_log {
499  #                       $row->{nick} = $nick;  #                       $row->{nick} = $nick;
500  #               }  #               }
501    
502                    $append = 0 if $row->{me};
503    
504                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
505                          # obfu way to find format for me_nick if needed or fallback to default                          # obfu way to find format for me_nick if needed or fallback to default
506                          my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};                          my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
# Line 494  sub add_tag { Line 553  sub add_tag {
553          return unless ($arg->{id} && $arg->{message});          return unless ($arg->{id} && $arg->{message});
554    
555          my $m = $arg->{message};          my $m = $arg->{message};
         from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
556    
557          my @tags;          my @tags;
558    
# Line 563  sub save_message { Line 621  sub save_message {
621                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
622                  " " . $a->{message};                  " " . $a->{message};
623    
624          from_to($a->{message}, 'UTF-8', $ENCODING);          $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
   
         $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});  
625          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
626  }  }
627    
# Line 604  if ($import_dircproxy) { Line 660  if ($import_dircproxy) {
660          exit;          exit;
661  }  }
662    
   
663  #  #
664  # POE handing part  # RSS follow
665  #  #
666    
667  my $SKIPPING = 0;               # if skipping, how many we've done  my $_stat;
668  my $SEND_QUEUE;                 # cache  
669  my $ping;                                               # ping stats  
670    sub rss_fetch {
671  POE::Component::IRC->new($IRC_ALIAS);          my ($args) = @_;
672    
673  POE::Session->create( inline_states =>          # how many messages to send out when feed is seen for the first time?
674     {_start => sub {                my $send_rss_msgs = 1;
675                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');  
676                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);          _log "RSS fetch", $args->{url};
677    
678            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
679            if ( ! $feed ) {
680                    _log("can't fetch RSS ", $args->{url});
681                    return;
682            }
683    
684            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
685    
686            my ( $total, $updates ) = ( 0, 0 );
687            for my $entry ($feed->entries) {
688                    $total++;
689    
690                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
691                    # seen allready?
692                    warn "## $seen_times ",$feed->link if $debug;
693                    next if $seen_times > 0;
694    
695                    sub prefix {
696                            my ($txt,$var) = @_;
697                            $var =~ s/\s+/ /gs;
698                            $var =~ s/^\s+//g;
699                            $var =~ s/\s+$//g;
700                            return $txt . $var if $var;
701                    }
702    
703                    # fix absolute and relative links to feed entries
704                    my $link = $entry->link;
705                    if ( $link =~ m!^/! ) {
706                            my $host = $args->{url};
707                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
708                            $link = "$host/$link";
709                    } elsif ( $link !~ m!^http! ) {
710                            $link = $args->{url} . $link;
711                    }
712    
713                    my $msg;
714                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
715                    $msg .= prefix( ' by ' , $entry->author );
716                    $msg .= prefix( ' | ' , $entry->title );
717                    $msg .= prefix( ' | ' , $link );
718    #               $msg .= prefix( ' id ' , $entry->id );
719                    if ( my $tags = $entry->category ) {
720                            $tags =~ s!^\s+!!;
721                            $tags =~ s!\s*$! !;
722                            $tags =~ s!,?\s+!// !g;
723                            $msg .= prefix( ' ' , $tags );
724                    }
725    
726                    if ( $seen_times == 0 && $send_rss_msgs ) {
727                            $send_rss_msgs--;
728                            if ( ! $args->{private} ) {
729                                    # FIXME bug! should be save_message
730                                    save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
731    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
732                            }
733                            my ( $type, $to ) = ( 'notice', $args->{channel} );
734                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
735    
736                            _log(">> $type $to", $msg);
737    #                       $args->{kernel}->post( $irc => $type => $to, $msg );
738                            # XXX enqueue message to send later
739                            sub enqueue_post {
740                                    my $post = dump( @_ );
741                                    warn "## queue_post $post\n" if $debug;
742                                    $dq->enqueue_string( $post );
743                            }
744                            enqueue_post( $type => $to => $msg );
745    
746                            $updates++;
747                    }
748            }
749    
750            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
751            $sql .= qq{, updates = updates + $updates } if $updates;
752            $sql .= qq{where id = } . $args->{id};
753            eval { $dbh->do( $sql ) };
754    
755            _log "RSS got $total items of which $updates new";
756    
757            return $updates;
758    }
759    
760    sub rss_fetch_all {
761            my $kernel = shift;
762            my $sql = qq{
763                    select id, url, name, channel, nick, private
764                    from feeds
765                    where active is true
766            };
767            # limit to newer feeds only if we are not sending messages out
768            $sql .= qq{     and last_update + delay < now() } if $kernel;
769            my $sth = $dbh->prepare( $sql );
770            $sth->execute();
771            warn "# ",$sth->rows," active RSS feeds\n";
772            my $count = 0;
773            while (my $row = $sth->fetchrow_hashref) {
774                    $row->{kernel} = $kernel if $kernel;
775                    $count += rss_fetch( $row );
776            }
777            return "OK, fetched $count posts from " . $sth->rows . " feeds";
778    }
779    
780    
781    sub rss_check_updates {
782            my $kernel = shift;
783            $_stat->{rss}->{last_poll} ||= time();
784            my $dt = time() - $_stat->{rss}->{last_poll};
785            if ( $dt > $rss_min_delay ) {
786                    warn "## rss_check_updates $dt > $rss_min_delay\n";
787                    $_stat->{rss}->{last_poll} = time();
788                    _log rss_fetch_all( $kernel );
789            }
790            # XXX send queue messages
791            while ( my $job = $dq->pickup_queued_job() ) {
792                    my $data = read_file( $job->get_data_path ) || die "can't load ", $job->get_data_path, ": $!";
793    #               $kernel->post( $irc => $type => $to, $msg );
794                    my @data = eval $data;
795                    _log ">> post from queue ", $irc, @data;
796                    $kernel->post( $irc => @data );
797                    $job->finish;
798                    warn "## done queued job: ",dump( @data ) if $debug;
799            }
800    }
801    
802    # seed rss seen cache so we won't send out all items on startup
803    _log rss_fetch_all if ! $debug;
804    
805    POE::Session->create( inline_states => {
806            _start => sub {      
807                    $_[KERNEL]->post( $irc => register => 'all' );
808                    $_[KERNEL]->post( $irc => connect => {} );
809      },      },
810            irc_001 => sub {
811                    my ($kernel,$sender) = @_[KERNEL,SENDER];
812                    my $poco_object = $sender->get_heap();
813                    _log "connected to",$poco_object->server_name();
814                    $kernel->post( $sender => join => $_ ) for @channels;
815                    undef;
816            },
817      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
818                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post( $irc => join => $CHANNEL);
                 $_[KERNEL]->post($IRC_ALIAS => join => '#logger');  
                 $_[KERNEL]->yield("heartbeat"); # start heartbeat  
 #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
819      },      },
820      irc_public => sub {      irc_public => sub {
821                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 635  POE::Session->create( inline_states => Line 825  POE::Session->create( inline_states =>
825    
826                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
827                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
828                    rss_check_updates( $kernel );
829      },      },
830      irc_ctcp_action => sub {      irc_ctcp_action => sub {
831                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 655  POE::Session->create( inline_states => Line 846  POE::Session->create( inline_states =>
846    
847      },      },
848          irc_ping => sub {          irc_ping => sub {
849                  warn "pong ", $_[ARG0], $/;                  _log( "pong ", $_[ARG0] );
850                  $ping->{ $_[ARG0] }++;                  $_stat->{ping}->{ $_[ARG0] }++;
851                    rss_check_updates( $_[KERNEL] );
852          },          },
853          irc_invite => sub {          irc_invite => sub {
854                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
855                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
856                  my $channel = $_[ARG1];                  my $channel = $_[ARG1];
857    
858                  warn "invited to $channel by $nick";                  _log "invited to $channel by $nick";
859    
860                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );                  $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
861                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post( $irc => 'join' => $channel );
862    
863          },          },
864          irc_msg => sub {          irc_msg => sub {
# Line 674  POE::Session->create( inline_states => Line 866  POE::Session->create( inline_states =>
866                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
867                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
868                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
869                  from_to($msg, 'UTF-8', $ENCODING);                  warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
870    
871                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
872                  my @out;                  my @out;
# Line 685  POE::Session->create( inline_states => Line 877  POE::Session->create( inline_states =>
877    
878                          $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";                          $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
879    
880                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
881    
882                          _log ">> /msg $1 $2";                          _log ">> /$1 $2 $3";
883                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $irc => $1 => $2, $3 );
884                          $res = '';                          $res = '';
885    
886                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
# Line 718  POE::Session->create( inline_states => Line 910  POE::Session->create( inline_states =>
910    
911                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
912                                  _log "last: $res";                                  _log "last: $res";
913                                  from_to($res, $ENCODING, 'UTF-8');                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
914                          }                          }
915    
916                          $res = '';                          $res = '';
# Line 733  POE::Session->create( inline_states => Line 924  POE::Session->create( inline_states =>
924                                          search => $what,                                          search => $what,
925                                  )) {                                  )) {
926                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
927                                  from_to($res, $ENCODING, 'UTF-8');                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
928                          }                          }
929    
930                          $res = '';                          $res = '';
# Line 769  POE::Session->create( inline_states => Line 959  POE::Session->create( inline_states =>
959                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
960                                  " from " . ( join(", ", @nicks) || 'nobody' );                                  " from " . ( join(", ", @nicks) || 'nobody' );
961    
962                          $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );                          $_[KERNEL]->post( $irc => notice => $nick, $res );
963    
964                  } elsif ($msg =~ m/^ping/) {                  } elsif ($msg =~ m/^ping/) {
965                          $res = "ping = " . dump( $ping );                          $res = "ping = " . dump( $_stat->{ping} );
966                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
967                          if ( ! defined( $1 ) ) {                          if ( ! defined( $1 ) ) {
968                                  my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });                                  my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
# Line 803  POE::Session->create( inline_states => Line 993  POE::Session->create( inline_states =>
993                                          $res = "config option $op doesn't exist";                                          $res = "config option $op doesn't exist";
994                                  }                                  }
995                          }                          }
996                    } elsif ($msg =~ m/^rss-update/) {
997                            $res = rss_fetch_all( $_[KERNEL] );
998                    } elsif ($msg =~ m/^rss-list/) {
999                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
1000                            $sth->execute;
1001                            while (my @row = $sth->fetchrow_array) {
1002                                    $_[KERNEL]->post( $irc => privmsg => $nick, join(' | ',@row) );
1003                            }
1004                            $res = '';
1005                    } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
1006                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
1007    
1008                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
1009                            $channel = $nick if $sub eq 'private';
1010    
1011                            my $sql = {
1012                                    add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
1013    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
1014                                    start   => qq{ update feeds set active = true   where url = ? },
1015                                    stop    => qq{ update feeds set active = false  where url = ? },
1016                                    clean   => qq{ update feeds set last_update = now() - delay where url = ? },
1017                            };
1018    
1019                            if ( $command eq 'add' && ! $channel ) {
1020                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
1021                            } elsif (my $q = $sql->{$command} ) {
1022                                    my $sth = $dbh->prepare( $q );
1023                                    my @data = ( $url );
1024                                    if ( $command eq 'add' ) {
1025                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
1026                                    }
1027                                    warn "## $command SQL $q with ",dump( @data ),"\n";
1028                                    eval { $sth->execute( @data ) };
1029                                    if ($@) {
1030                                            $res = "ERROR: $@";
1031                                    } else {
1032                                            $res = "OK, RSS executed $command " . ( $sub ? "-$sub" : '' ) ."on $channel url $url";
1033                                            if ( $command eq 'clean' ) {
1034                                                    my $seen = $_stat->{rss}->{seen} || die "no seen?";
1035                                                    my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
1036                                                    foreach my $c ( keys %$seen ) {
1037                                                            my $c_hash = $seen->{$c} || die "no seen->{$c}";
1038                                                            die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
1039                                                            foreach my $link ( keys %$c_hash ) {
1040                                                                    next unless $link eq $want_link;
1041                                                                    _log "RSS removed seen $c $url $link";
1042                                                            }
1043                                                    }
1044                                            }
1045                                    }
1046                            } else {
1047                                    $res = "ERROR: don't know what to do with: $msg";
1048                            }
1049                    } elsif ($msg =~ m/^rss-clean/) {
1050                            # this makes sense because we didn't catch rss-clean http://... before!
1051                            $_stat->{rss} = undef;
1052                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
1053                            $res = "OK, cleaned RSS cache";
1054                  }                  }
1055    
1056                  if ($res) {                  if ($res) {
1057                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
1058                          from_to($res, $ENCODING, 'UTF-8');                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                         $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
1059                  }                  }
1060    
1061                    rss_check_updates( $_[KERNEL] );
1062            },
1063            irc_372 => sub {
1064                    _log "<< motd",$_[ARG0],$_[ARG1];
1065            },
1066            irc_375 => sub {
1067                    _log "<< motd", $_[ARG0], "start";
1068          },          },
1069            irc_376 => sub {
1070                    _log "<< motd", $_[ARG0], "end";
1071            },
1072    #       irc_433 => sub {
1073    #               print "# irc_433: ",$_[ARG1], "\n";
1074    #               warn "## indetify $NICK\n";
1075    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1076    #       },
1077    #       irc_451 # please register
1078          irc_477 => sub {          irc_477 => sub {
1079                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
1080                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> IDENTIFY $NICK";
1081                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1082          },          },
1083          irc_505 => sub {          irc_505 => sub {
1084                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
1085                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> register $NICK";
1086  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );                  $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1087  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1088    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1089    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1090          },          },
1091          irc_registered => sub {          irc_registered => sub {
1092                  _log "## registrated $NICK";                  _log "<< registered $NICK";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1093          },          },
1094          irc_disconnected => sub {          irc_disconnected => sub {
1095                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1096                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1097                    $_[KERNEL]->post( $irc => connect => {} );
1098          },          },
1099          irc_socketerr => sub {          irc_socketerr => sub {
1100                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1101                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1102                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
1103            },
1104            irc_notice => sub {
1105                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1106                    my $m = $_[ARG2];
1107                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1108                            _log ">> suggested to $1 $2";
1109                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1110                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1111                            _log ">> registreted, so IDENTIFY";
1112                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1113                    } else {
1114                            warn "## ignore $m\n" if $debug;
1115                    }
1116            },
1117            irc_snotice => sub {
1118                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1119                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1120                            warn ">> $1 | $2\n";
1121                            $_[KERNEL]->post( $irc => lc($1) => $2);
1122                    }
1123          },          },
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
1124      _child => sub {},      _child => sub {},
1125      _default => sub {      _default => sub {
1126                  _log sprintf "sID:%s %s %s",                  _log sprintf "sID:%s %s %s",
# Line 849  POE::Session->create( inline_states => Line 1130  POE::Session->create( inline_states =>
1130                          "";                          "";
1131        0;                        # false for signals        0;                        # false for signals
1132      },      },
     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);  
     }  
1133     },     },
1134    );    );
1135    
1136  # http server  # http server
1137    
1138    _log "WEB archive at $url";
1139    
1140  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1141          Port => $http_port,          Port => $http_port,
1142          PreHandler => {          PreHandler => {
# Line 960  foreach my $c (@cols) { Line 1183  foreach my $c (@cols) {
1183          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1184          $max_color++;          $max_color++;
1185  }  }
1186  warn "defined $max_color colors for users...\n";  _log "WEB defined $max_color colors for users...";
1187    
1188  sub root_handler {  sub root_handler {
1189          my ($request, $response) = @_;          my ($request, $response) = @_;
# Line 982  sub root_handler { Line 1205  sub root_handler {
1205          }          }
1206    
1207          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1208            my $r_url = $request->url;
1209    
1210            my @commands = qw( tags last-tag follow stat );
1211            my $commands_re = join('|',@commands);
1212    
1213          if ($request->url =~ m#/rss(?:/(tags|last-tag)\w*(?:=(\d+))?)?#i) {          if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1214                  my $show = lc($1);                  my $show = lc($1);
1215                  my $nr = $2;                  my $nr = $2;
1216    
# Line 995  sub root_handler { Line 1222  sub root_handler {
1222                  #warn "create $type feed from ",dump( @last_tags );                  #warn "create $type feed from ",dump( @last_tags );
1223    
1224                  my $feed = XML::Feed->new( $type );                  my $feed = XML::Feed->new( $type );
1225                    $feed->link( $url );
1226    
1227                    my $rc = RC_OK;
1228    
1229                  if ( $show eq 'tags' ) {                  if ( $show eq 'tags' ) {
1230                          $nr ||= 50;                          $nr ||= 50;
# Line 1021  sub root_handler { Line 1251  sub root_handler {
1251                          $nr = $last_x_tags if $nr > $last_x_tags;                          $nr = $last_x_tags if $nr > $last_x_tags;
1252    
1253                          $feed->title( "last $nr tagged messages from $CHANNEL" );                          $feed->title( "last $nr tagged messages from $CHANNEL" );
                         $feed->link( $url );  
1254                          $feed->description( "collects messages which have tags// in them" );                          $feed->description( "collects messages which have tags// in them" );
1255    
1256                          foreach my $m ( @last_tags ) {                          foreach my $m ( @last_tags ) {
# Line 1036  sub root_handler { Line 1265  sub root_handler {
1265                                  my $message = $filter->{message}->( $m->{message} );                                  my $message = $filter->{message}->( $m->{message} );
1266                                  $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;                                  $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1267  #                               warn "## message = $message\n";  #                               warn "## message = $message\n";
                                 from_to( $message, $ENCODING, 'UTF-8' );  
1268    
1269                                  #$feed_entry->summary(                                  #$feed_entry->summary(
1270                                  $feed_entry->content(                                  $feed_entry->content(
# Line 1050  sub root_handler { Line 1278  sub root_handler {
1278    
1279                          }                          }
1280    
1281                    } elsif ( $show =~ m/^follow/ ) {
1282    
1283                            $feed->title( "Feeds which this bot follows" );
1284    
1285                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1286                            $sth->execute;
1287                            while (my $row = $sth->fetchrow_hashref) {
1288                                    my $feed_entry = XML::Feed::Entry->new($type);
1289                                    $feed_entry->title( $row->{name} );
1290                                    $feed_entry->link( $row->{url}  );
1291                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1292                                    $feed_entry->content(
1293                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1294                                    );
1295                                    $feed->add_entry( $feed_entry );
1296                            }
1297    
1298                    } elsif ( $show =~ m/^stat/ ) {
1299    
1300                            my $feed_entry = XML::Feed::Entry->new($type);
1301                            $feed_entry->title( "Internal stats" );
1302                            $feed_entry->content(
1303                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1304                            );
1305                            $feed->add_entry( $feed_entry );
1306    
1307                  } else {                  } else {
1308                          warn "!! unknown rss request for $show\n";                          _log "WEB unknown rss request $r_url";
1309                          return RC_DENY;                          $feed->title( "unknown $r_url" );
1310                            foreach my $c ( @commands ) {
1311                                    my $feed_entry = XML::Feed::Entry->new($type);
1312                                    $feed_entry->title( "rss/$c" );
1313                                    $feed_entry->link( "$url/rss/$c" );
1314                                    $feed->add_entry( $feed_entry );
1315                            }
1316                            $rc = RC_DENY;
1317                  }                  }
1318    
1319                  $response->content( $feed->as_xml );                  $response->content( $feed->as_xml );
1320                  return RC_OK;                  return $rc;
1321          }          }
1322    
1323          if ( $@ ) {          if ( $@ ) {
1324                  warn "$@";                  warn "$@";
1325          }          }
1326    
1327          $response->content_type("text/html; charset=$ENCODING");          $response->content_type("text/html; charset=UTF-8");
1328    
1329          my $html =          my $html =
1330                  qq{<html><head><title>$NICK</title><style type="text/css">$style}                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
# Line 1114  sub root_handler { Line 1375  sub root_handler {
1375                          }                          }
1376                          $cal->setcontent($dd, qq[                          $cal->setcontent($dd, qq[
1377                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1378                          ]);                          ]) if $cal;
1379                                                    
1380                  }                  }
1381                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
Legend:
Removed from v.83  
changed lines
  Added in v.120
  ViewVC Help
Powered by ViewVC 1.1.26