/[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 92 by dpavlin, Fri Mar 7 10:30:57 2008 UTC revision 125 by dpavlin, Fri Mar 14 15:26:33 2008 UTC
# Line 2  Line 2 
2  use strict;  use strict;
3  $|++;  $|++;
4    
5    use POE qw(Component::IRC Component::Server::HTTP Component::Client::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    use Encode;
24    
25  =head1 NAME  =head1 NAME
26    
27  irc-logger.pl  irc-logger.pl
# Line 30  log all conversation on irc channel Line 50  log all conversation on irc channel
50    
51  ## CONFIG  ## CONFIG
52    
53    my $debug = 0;
54    
55    my $irc_config = {
56            nick => 'irc-logger',
57            server => 'irc.freenode.net',
58            port => 6667,
59            ircname => 'Anna the bot: try /msg irc-logger help',
60    };
61    
62    my $queue_dir = './queue';
63    
64  my $HOSTNAME = `hostname -f`;  my $HOSTNAME = `hostname -f`;
65  chomp($HOSTNAME);  chomp($HOSTNAME);
66    
67  my $NICK = 'irc-logger';  
 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  
 my $CONNECT =  
   {Server => 'irc.freenode.net',  
    Nick => $NICK,  
    Ircname => "try /msg $NICK help",  
   };  
68  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
69  $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  
70  my $IRC_ALIAS = "log";  if ( $HOSTNAME =~ m/llin/ ) {
71            $irc_config->{nick} = 'irc-logger-llin';
72    #       $irc_config = {
73    #               nick => 'irc-logger-llin',
74    #               server => 'localhost',
75    #               port => 6668,
76    #       };
77            $CHANNEL = '#irc-logger';
78    } elsif ( $HOSTNAME =~ m/lugarin/ ) {
79            $irc_config->{server} = 'irc.carnet.hr';
80            $CHANNEL = '#riss';
81    }
82    
83    my @channels = ( $CHANNEL );
84    
85    warn "## config = ", dump( $irc_config ) if $debug;
86    
87    my $NICK = $irc_config->{nick} or die "no nick?";
88    
89  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
90    
# Line 55  my $last_x_tags = 50; Line 97  my $last_x_tags = 50;
97    
98  # don't pull rss feeds more often than this  # don't pull rss feeds more often than this
99  my $rss_min_delay = 60;  my $rss_min_delay = 60;
 $rss_min_delay = 15;  
100    
101  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
102    
# Line 63  my $url = "http://$HOSTNAME:$http_port"; Line 104  my $url = "http://$HOSTNAME:$http_port";
104    
105  ## END CONFIG  ## END CONFIG
106    
 use POE qw(Component::IRC Component::Server::HTTP);  
 use HTTP::Status;  
 use DBI;  
 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;  
   
107  my $use_twitter = 1;  my $use_twitter = 1;
108  eval { require Net::Twitter; };  eval { require Net::Twitter; };
109  $use_twitter = 0 if ($@);  $use_twitter = 0 if ($@);
# Line 89  my $log_path; Line 113  my $log_path;
113  GetOptions(  GetOptions(
114          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
115          'log:s' => \$log_path,          'log:s' => \$log_path,
116            'queue:s' => \$queue_dir,
117            'debug!' => \$debug,
118  );  );
119    
120  #$SIG{__DIE__} = sub {  #$SIG{__DIE__} = sub {
121  #       confess "fatal error";  #       confess "fatal error";
122  #};  #};
123    
 open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  
   
124  sub _log {  sub _log {
125          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
126    }
127    
128    open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
129    
130    # queue
131    
132    if ( ! -d $queue_dir ) {
133            warn "## creating queue directory $queue_dir";
134            mkdir $queue_dir or die "can't create queue directory $queue_dir: $!";
135  }  }
136    
137    my $dq = IPC::DirQueue->new({ dir => $queue_dir });
138    
139  # HTML formatters  # HTML formatters
140    
141  my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
# Line 118  my $filter = { Line 153  my $filter = {
153                  # protect HTML from wiki modifications                  # protect HTML from wiki modifications
154                  sub e {                  sub e {
155                          my $t = shift;                          my $t = shift;
156                          return 'uri_unescape{' . uri_escape($t) . '}';                          return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
157                  }                  }
158    
159                  $m =~ s/($escape_re)/$escape{$1}/gs;                  $m =~ s/($escape_re)/$escape{$1}/gs;
160                  $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;
161                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
162                  $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;
163                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
# Line 143  my $filter = { Line 178  my $filter = {
178          },          },
179  };  };
180    
181    # POE IRC
182    my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
183            die "can't start ", dump( $irc_config ), ": $!";
184    
185    my $irc = $poe_irc->session_id();
186    _log "IRC session_id $irc";
187    
188  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
189  $dbh->do( qq{ set client_encoding = 'UTF-8' } );  $dbh->do( qq{ set client_encoding = 'UTF-8' } );
190    
# Line 179  create table feeds ( Line 221  create table feeds (
221          name text,          name text,
222          delay interval not null default '5 min',          delay interval not null default '5 min',
223          active boolean default true,          active boolean default true,
224            channel text not null,
225            nick text not null,
226            private boolean default false,
227          last_update timestamp default 'now()',          last_update timestamp default 'now()',
228          polls int default 0,          polls int default 0,
229          updates int default 0          updates int default 0
230  );  );
231  create unique index feeds_url on feeds(url);  create unique index feeds_url on feeds(url);
232  insert into feeds (url,name) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki');  insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
233          },          },
234  };  };
235    
# Line 228  sub meta { Line 273  sub meta {
273                  if ( $@ || ! $sth->rows ) {                  if ( $@ || ! $sth->rows ) {
274                          $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()) });
275                          $sth->execute( $value, $nick, $channel, $name );                          $sth->execute( $value, $nick, $channel, $name );
276                          _log "created $nick/$channel/$name = $value";                          warn "## created $nick/$channel/$name = $value\n";
277                  } else {                  } else {
278                          _log "updated $nick/$channel/$name = $value ";                          warn "## updated $nick/$channel/$name = $value\n";
279                  }                  }
280    
281                  return $value;                  return $value;
# Line 240  sub meta { Line 285  sub meta {
285                  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 = ? });
286                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
287                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
288                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
289                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
290                  return $v;                  return $v;
291    
# Line 337  sub get_from_log { Line 382  sub get_from_log {
382    
383          my @where;          my @where;
384          my @args;          my @args;
385            my $msg;
386    
387          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
388                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
389                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
390                  push @where, 'message ilike ? or nick ilike ?';                  push @where, 'message ilike ? or nick ilike ?';
391                  push @args, ( ( '%' . $search . '%' ) x 2 );                  push @args, ( ( '%' . $search . '%' ) x 2 );
392                  _log "search for '$search'";                  $msg = "Search for '$search'";
393          }          }
394    
395          if ($args->{tag} && $tags->{ $args->{tag} }) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
396                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
397                  _log "search for tags $args->{tag}";                  $msg = "Search for tags $args->{tag}";
398          }          }
399    
400          if (my $date = $args->{date} ) {          if (my $date = $args->{date} ) {
401                  $date = check_date( $date );                  $date = check_date( $date );
402                  push @where, 'date(time) = ?';                  push @where, 'date(time) = ?';
403                  push @args, $date;                  push @args, $date;
404                  _log "search for date $date";                  $msg = "search for date $date";
405          }          }
406    
407          $sql .= " where " . join(" and ", @where) if @where;          $sql .= " where " . join(" and ", @where) if @where;
# Line 369  sub get_from_log { Line 415  sub get_from_log {
415          eval { $sth->execute( @args ) };          eval { $sth->execute( @args ) };
416          return if $@;          return if $@;
417    
418            my $nr_results = $sth->rows;
419    
420          my $last_row = {          my $last_row = {
421                  date => '',                  date => '',
422                  time => '',                  time => '',
# Line 389  sub get_from_log { Line 437  sub get_from_log {
437    
438          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
439    
440          my @msgs = (          $msg .= ' produced ' . (
441                  "Showing " . ($#rows + 1) . " messages..."                  $nr_results == 0 ? 'no results' :
442                    $nr_results == 0 ? 'one result' :
443                            $nr_results . ' results'
444          );          );
445    
446            my @msgs = ( $msg );
447    
448          if ($context) {          if ($context) {
449                  my @ids = @rows;                  my @ids = @rows;
450                  @rows = ();                  @rows = ();
# Line 449  sub get_from_log { Line 501  sub get_from_log {
501  #                       $row->{nick} = $nick;  #                       $row->{nick} = $nick;
502  #               }  #               }
503    
504                    $append = 0 if $row->{me};
505    
506                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
507                          # 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
508                          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 564  sub save_message { Line 618  sub save_message {
618          $a->{me} ||= 0;          $a->{me} ||= 0;
619          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
620    
621          _log          _log "ARCHIVE",
622                  $a->{channel}, " ",                  $a->{channel}, " ",
623                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
624                  " " . $a->{message};                  " " . $a->{message};
# Line 612  if ($import_dircproxy) { Line 666  if ($import_dircproxy) {
666  # RSS follow  # RSS follow
667  #  #
668    
669  my $_rss;  my $_stat;
670    
671    POE::Component::Client::HTTP->spawn(
672            Alias   => 'rss-fetch',
673            Timeout => 30,
674    );
675    
676    =head2 rss_parse_xml
677    
678      rss_parse_xml({
679            url => 'http://www.example.com/rss',
680            send_rss_msgs => 42,
681      });
682    
683    =cut
684    
685  sub rss_fetch {  sub rss_parse_xml {
686          my ($args) = @_;          my ($args) = @_;
687    
688            warn "## rss_parse_xml ",dump( @_ ) if $debug;
689    
690          # how many messages to send out when feed is seen for the first time?          # how many messages to send out when feed is seen for the first time?
691          my $send_rss_msgs = 1;          my $send_rss_msgs = $args->{send_rss_msgs};
692            $send_rss_msgs = 1 if ! defined $send_rss_msgs;
693    
694          _log "RSS fetch", $args->{url};          _log "RSS fetch first $send_rss_msgs items from", $args->{url};
695    
696          my $feed = XML::Feed->parse(URI->new( $args->{url} ));          my $feed = XML::Feed->parse( \$args->{xml} );
697          if ( ! $feed ) {          if ( ! $feed ) {
698                  _log("can't fetch RSS ", $args->{url});                  _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
699                  return;                  return;
700          }          }
701    
702            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
703    
704          my ( $total, $updates ) = ( 0, 0 );          my ( $total, $updates ) = ( 0, 0 );
705          for my $entry ($feed->entries) {          for my $entry ($feed->entries) {
706                  $total++;                  $total++;
707    
708                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
709                  # seen allready?                  # seen allready?
710                  next if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;                  warn "## $seen_times ",$entry->id if $debug;
711                    next if $seen_times > 0;
712    
713                  sub prefix {                  sub prefix {
714                          my ($txt,$var) = @_;                          my ($txt,$var) = @_;
715                            $var =~ s/\s+/ /gs;
716                          $var =~ s/^\s+//g;                          $var =~ s/^\s+//g;
717                            $var =~ s/\s+$//g;
718                          return $txt . $var if $var;                          return $txt . $var if $var;
719                  }                  }
720    
721                    # fix absolute and relative links to feed entries
722                    my $link = $entry->link;
723                    if ( $link =~ m!^/! ) {
724                            my $host = $args->{url};
725                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
726                            $link = "$host/$link";
727                    } elsif ( $link !~ m!^http! ) {
728                            $link = $args->{url} . $link;
729                    }
730    
731                  my $msg;                  my $msg;
732                  $msg .= prefix( 'From: ' , $args->{name} || $feed->title );                  $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
733                  $msg .= prefix( ' by ' , $entry->author );                  $msg .= prefix( ' by ' , $entry->author );
734                  $msg .= prefix( ' | ' , $entry->title );                  $msg .= prefix( ' | ' , $entry->title );
735                  $msg .= prefix( ' | ' , $entry->link );                  $msg .= prefix( ' | ' , $link );
736  #               $msg .= prefix( ' id ' , $entry->id );  #               $msg .= prefix( ' id ' , $entry->id );
737                    if ( my $tags = $entry->category ) {
738                            $tags =~ s!^\s+!!;
739                            $tags =~ s!\s*$! !;
740                            $tags =~ s!,?\s+!// !g;
741                            $msg .= prefix( ' ' , $tags );
742                    }
743    
744                  if ( $args->{kernel} && $send_rss_msgs ) {                  if ( $seen_times == 0 && $send_rss_msgs ) {
745                          $send_rss_msgs--;                          $send_rss_msgs--;
746                          _log('>>', $msg);                          if ( ! $args->{private} ) {
747                          $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, 'now()' );                                  # FIXME bug! should be save_message
748                          $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );                                  save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
749    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
750                            }
751                            my ( $type, $to ) = ( 'notice', $args->{channel} );
752                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
753    
754                            _log("RSS generated $type to $to:", $msg);
755                            # XXX enqueue message to send later
756                            sub enqueue_post {
757                                    my $post = dump( @_ );
758                                    warn "## queue_post $post\n" if $debug;
759                                    $dq->enqueue_string( $post );
760                            }
761                            enqueue_post( $type => $to => $msg );
762    
763                          $updates++;                          $updates++;
764                  }                  }
765          }          }
# Line 663  sub rss_fetch { Line 769  sub rss_fetch {
769          $sql .= qq{where id = } . $args->{id};          $sql .= qq{where id = } . $args->{id};
770          eval { $dbh->do( $sql ) };          eval { $dbh->do( $sql ) };
771    
772          _log "RSS got $total items of which $updates new";          _log "RSS got $total items of which $updates new from", $args->{url};
773    
774          return $updates;          return $updates;
775  }  }
776    
777  sub rss_fetch_all {  sub rss_fetch_all {
778          my $kernel = shift;          my ( $kernel, $send_rss_msgs )  = @_;
779            warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug;
780          my $sql = qq{          my $sql = qq{
781                  select id, url, name                  select id, url, name, channel, nick, private
782                  from feeds                  from feeds
783                  where active is true                  where active is true
784          };          };
785          # limit to newer feeds only if we are not sending messages out          # limit to newer feeds only if we are not sending messages out
786          $sql .= qq{     and last_update + delay < now() } if $kernel;          $sql .= qq{     and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
787          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
788          $sth->execute();          $sth->execute();
789          warn "# ",$sth->rows," active RSS feeds\n";          warn "# ",$sth->rows," active RSS feeds\n";
790          my $count = 0;          my $count = 0;
791          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
792                  $row->{kernel} = $kernel if $kernel;                  $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs;
793                  $count += rss_fetch( $row );                  $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
794                    $kernel->post(
795                            'rss-fetch',
796                            'request',
797                            'rss_response',
798                            HTTP::Request->new( GET => $row->{url} ),
799                    );
800                    warn "## queued rss-fetch ", dump( $row ) if $debug;
801          }          }
802          return "OK, fetched $count posts from " . $sth->rows . " feeds";          return "OK, scheduled " . $sth->rows . " feeds for refresh";
803  }  }
804    
805    
806  sub rss_check_updates {  sub rss_check_updates {
807          my $kernel = shift;          my $kernel = shift;
808          my $last_t = $_rss->{last_poll} || time();          $_stat->{rss}->{last_poll} ||= time();
809          my $t = time();          my $dt = time() - $_stat->{rss}->{last_poll};
810          if ( $t - $last_t > $rss_min_delay ) {          if ( $dt > $rss_min_delay ) {
811                  $_rss->{last_poll} = $t;                  warn "## rss_check_updates $dt > $rss_min_delay\n";
812                    $_stat->{rss}->{last_poll} = time();
813                  _log rss_fetch_all( $kernel );                  _log rss_fetch_all( $kernel );
814          }          }
815            # XXX send queue messages
816            while ( my $job = $dq->pickup_queued_job() ) {
817                    my $data = read_file( $job->get_data_path ) || die "can't load ", $job->get_data_path, ": $!";
818                    my @data = eval $data;
819                    _log "IRC post from queue:", @data;
820                    $kernel->post( $irc => @data );
821                    $job->finish;
822                    warn "## done queued job: ",dump( @data ) if $debug;
823            }
824  }  }
825    
 # seed rss seen cache so we won't send out all items on startup  
 _log rss_fetch_all;  
   
 #  
 # POE handing part  
 #  
   
 my $ping;                                               # ping stats  
   
 POE::Component::IRC->new($IRC_ALIAS);  
   
826  POE::Session->create( inline_states => {  POE::Session->create( inline_states => {
827          _start => sub {                _start => sub {      
828                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post( $irc => register => 'all' );
829                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
     },  
     irc_255 => sub {    # server is done blabbing  
                 $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);  
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
830      },      },
831            irc_001 => sub {
832                    my ($kernel,$sender) = @_[KERNEL,SENDER];
833                    my $poco_object = $sender->get_heap();
834                    _log "connected to",$poco_object->server_name();
835                    $kernel->post( $sender => join => $_ ) for @channels;
836                    # seen RSS cache, so don't send out messages
837                    _log rss_fetch_all( $kernel, 0 );
838                    undef;
839            },
840    #       irc_255 => sub {        # server is done blabbing
841    #               $_[KERNEL]->post( $irc => join => $CHANNEL);
842    #       },
843      irc_public => sub {      irc_public => sub {
844                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
845                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
# Line 727  POE::Session->create( inline_states => { Line 848  POE::Session->create( inline_states => {
848    
849                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
850                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
851                    rss_check_updates( $kernel );
852      },      },
853      irc_ctcp_action => sub {      irc_ctcp_action => sub {
854                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 748  POE::Session->create( inline_states => { Line 870  POE::Session->create( inline_states => {
870      },      },
871          irc_ping => sub {          irc_ping => sub {
872                  _log( "pong ", $_[ARG0] );                  _log( "pong ", $_[ARG0] );
873                  $ping->{ $_[ARG0] }++;                  $_stat->{ping}->{ $_[ARG0] }++;
874                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
875          },          },
876          irc_invite => sub {          irc_invite => sub {
# Line 758  POE::Session->create( inline_states => { Line 880  POE::Session->create( inline_states => {
880    
881                  _log "invited to $channel by $nick";                  _log "invited to $channel by $nick";
882    
883                  $_[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..." );
884                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post( $irc => 'join' => $channel );
885    
886          },          },
887          irc_msg => sub {          irc_msg => sub {
# Line 767  POE::Session->create( inline_states => { Line 889  POE::Session->create( inline_states => {
889                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
890                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
891                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
892                    warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
893    
894                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
895                  my @out;                  my @out;
# Line 777  POE::Session->create( inline_states => { Line 900  POE::Session->create( inline_states => {
900    
901                          $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";
902    
903                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
904    
905                          _log ">> /msg $1 $2";                          _log ">> /$1 $2 $3";
906                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $irc => $1 => $2, $3 );
907                          $res = '';                          $res = '';
908    
909                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
# Line 810  POE::Session->create( inline_states => { Line 933  POE::Session->create( inline_states => {
933    
934                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
935                                  _log "last: $res";                                  _log "last: $res";
936                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
937                          }                          }
938    
939                          $res = '';                          $res = '';
# Line 824  POE::Session->create( inline_states => { Line 947  POE::Session->create( inline_states => {
947                                          search => $what,                                          search => $what,
948                                  )) {                                  )) {
949                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
950                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
951                          }                          }
952    
953                          $res = '';                          $res = '';
# Line 859  POE::Session->create( inline_states => { Line 982  POE::Session->create( inline_states => {
982                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
983                                  " from " . ( join(", ", @nicks) || 'nobody' );                                  " from " . ( join(", ", @nicks) || 'nobody' );
984    
985                          $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );                          $_[KERNEL]->post( $irc => notice => $nick, $res );
986    
987                  } elsif ($msg =~ m/^ping/) {                  } elsif ($msg =~ m/^ping/) {
988                          $res = "ping = " . dump( $ping );                          $res = "ping = " . dump( $_stat->{ping} );
989                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
990                          if ( ! defined( $1 ) ) {                          if ( ! defined( $1 ) ) {
991                                  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 895  POE::Session->create( inline_states => { Line 1018  POE::Session->create( inline_states => {
1018                          }                          }
1019                  } elsif ($msg =~ m/^rss-update/) {                  } elsif ($msg =~ m/^rss-update/) {
1020                          $res = rss_fetch_all( $_[KERNEL] );                          $res = rss_fetch_all( $_[KERNEL] );
                 } elsif ($msg =~ m/^rss-clean/) {  
                         $_rss = undef;  
                         $dbh->do( qq{ update feeds set last_update = now() - delay } );  
                         $res = "OK, cleaned RSS cache";  
1021                  } elsif ($msg =~ m/^rss-list/) {                  } elsif ($msg =~ m/^rss-list/) {
1022                          my $sth = $dbh->prepare(qq{ select url,name,last_update,active from feeds });                          my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
1023                          $sth->execute;                          $sth->execute;
1024                          while (my @row = $sth->fetchrow_array) {                          while (my @row = $sth->fetchrow_array) {
1025                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );                                  $_[KERNEL]->post( $irc => privmsg => $nick, join(' | ',@row) );
1026                          }                          }
1027                          $res = '';                          $res = '';
1028                  } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {                  } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
1029                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
1030    
1031                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
1032                            $channel = $nick if $sub eq 'private';
1033    
1034                          my $sql = {                          my $sql = {
1035                                  add             => qq{ insert into feeds (url,name) values (?,?) },                                  add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
1036  #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },  #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
1037                                  start   => qq{ update feeds set active = true   where url = ? },                                  start   => qq{ update feeds set active = true   where url = ? },
1038                                  stop    => qq{ update feeds set active = false  where url = ? },                                  stop    => qq{ update feeds set active = false  where url = ? },
1039                                                                    clean   => qq{ update feeds set last_update = now() - delay where url = ? },
1040                          };                          };
1041                          if (my $q = $sql->{$1} ) {  
1042                            if ( $command eq 'add' && ! $channel ) {
1043                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
1044                            } elsif (my $q = $sql->{$command} ) {
1045                                  my $sth = $dbh->prepare( $q );                                  my $sth = $dbh->prepare( $q );
1046                                  my @data = ( $2 );                                  my @data = ( $url );
1047                                  push @data, $3 if ( $q =~ s/\?//g == 2 );                                  if ( $command eq 'add' ) {
1048                                  warn "## $1 SQL $q with ",dump( @data ),"\n";                                          push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
1049                                    }
1050                                    warn "## $command SQL $q with ",dump( @data ),"\n";
1051                                  eval { $sth->execute( @data ) };                                  eval { $sth->execute( @data ) };
1052                                    if ($@) {
1053                                            $res = "ERROR: $@";
1054                                    } else {
1055                                            $res = "OK, RSS executed $command " . ( $sub ? "-$sub" : '' ) ."on $channel url $url";
1056                                            if ( $command eq 'clean' ) {
1057                                                    my $seen = $_stat->{rss}->{seen} || die "no seen?";
1058                                                    my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
1059                                                    foreach my $c ( keys %$seen ) {
1060                                                            my $c_hash = $seen->{$c} || die "no seen->{$c}";
1061                                                            die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
1062                                                            foreach my $link ( keys %$c_hash ) {
1063                                                                    next unless $link eq $want_link;
1064                                                                    _log "RSS removed seen $c $url $link";
1065                                                            }
1066                                                    }
1067                                            }
1068                                    }
1069                            } else {
1070                                    $res = "ERROR: don't know what to do with: $msg";
1071                          }                          }
1072                    } elsif ($msg =~ m/^rss-clean/) {
1073                          $res = "OK, RSS $1 : $2 - $3";                          # this makes sense because we didn't catch rss-clean http://... before!
1074                            $_stat->{rss} = undef;
1075                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
1076                            $res = "OK, cleaned RSS cache";
1077                  }                  }
1078    
1079                  if ($res) {                  if ($res) {
1080                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
1081                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1082                  }                  }
1083    
1084                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
1085          },          },
1086            irc_372 => sub {
1087                    _log "<< motd",$_[ARG0],$_[ARG1];
1088            },
1089            irc_375 => sub {
1090                    _log "<< motd", $_[ARG0], "start";
1091            },
1092            irc_376 => sub {
1093                    _log "<< motd", $_[ARG0], "end";
1094            },
1095    #       irc_433 => sub {
1096    #               print "# irc_433: ",$_[ARG1], "\n";
1097    #               warn "## indetify $NICK\n";
1098    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1099    #       },
1100    #       irc_451 # please register
1101          irc_477 => sub {          irc_477 => sub {
1102                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
1103                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> IDENTIFY $NICK";
1104                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1105          },          },
1106          irc_505 => sub {          irc_505 => sub {
1107                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
1108                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> register $NICK";
1109  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );                  $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1110  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1111    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1112    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1113          },          },
1114          irc_registered => sub {          irc_registered => sub {
1115                  _log "## registrated $NICK";                  _log "<< registered $NICK";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1116          },          },
1117          irc_disconnected => sub {          irc_disconnected => sub {
1118                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1119                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1120                    $_[KERNEL]->post( $irc => connect => {} );
1121          },          },
1122          irc_socketerr => sub {          irc_socketerr => sub {
1123                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1124                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1125                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
1126            },
1127            irc_notice => sub {
1128                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1129                    my $m = $_[ARG2];
1130                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1131                            _log ">> suggested to $1 $2";
1132                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1133                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1134                            _log ">> registreted, so IDENTIFY";
1135                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1136                    } else {
1137                            warn "## ignore $m\n" if $debug;
1138                    }
1139            },
1140            irc_snotice => sub {
1141                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1142                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1143                            warn ">> $1 | $2\n";
1144                            $_[KERNEL]->post( $irc => lc($1) => $2);
1145                    }
1146          },          },
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
1147      _child => sub {},      _child => sub {},
1148      _default => sub {      _default => sub {
1149                  _log sprintf "sID:%s %s %s",                  _log sprintf "sID:%s %s %s",
# Line 969  POE::Session->create( inline_states => { Line 1153  POE::Session->create( inline_states => {
1153                          "";                          "";
1154        0;                        # false for signals        0;                        # false for signals
1155      },      },
1156            rss_response => sub {
1157                    my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1158                    my $request_object  = $request_packet->[0];
1159                    my $response_object = $response_packet->[0];
1160    
1161                    my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1162                    if ( $row ) {
1163                            $row->{xml} = $response_object->content;
1164                            rss_parse_xml( $row );
1165                    } else {
1166                            warn "## can't find rss->fetch for ", $request_object->uri;
1167                    }
1168            },
1169     },     },
1170    );    );
1171    
1172  # http server  # http server
1173    
1174    _log "WEB archive at $url";
1175    
1176  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1177          Port => $http_port,          Port => $http_port,
1178          PreHandler => {          PreHandler => {
# Line 1020  foreach my $c (@cols) { Line 1219  foreach my $c (@cols) {
1219          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1220          $max_color++;          $max_color++;
1221  }  }
1222  warn "defined $max_color colors for users...\n";  _log "WEB defined $max_color colors for users...";
1223    
1224  sub root_handler {  sub root_handler {
1225          my ($request, $response) = @_;          my ($request, $response) = @_;
# Line 1042  sub root_handler { Line 1241  sub root_handler {
1241          }          }
1242    
1243          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1244            my $r_url = $request->url;
1245    
1246            my @commands = qw( tags last-tag follow stat );
1247            my $commands_re = join('|',@commands);
1248    
1249          if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {          if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1250                  my $show = lc($1);                  my $show = lc($1);
1251                  my $nr = $2;                  my $nr = $2;
1252    
# Line 1057  sub root_handler { Line 1260  sub root_handler {
1260                  my $feed = XML::Feed->new( $type );                  my $feed = XML::Feed->new( $type );
1261                  $feed->link( $url );                  $feed->link( $url );
1262    
1263                    my $rc = RC_OK;
1264    
1265                  if ( $show eq 'tags' ) {                  if ( $show eq 'tags' ) {
1266                          $nr ||= 50;                          $nr ||= 50;
1267                          $feed->title( "tags from $CHANNEL" );                          $feed->title( "tags from $CHANNEL" );
# Line 1126  sub root_handler { Line 1331  sub root_handler {
1331                                  $feed->add_entry( $feed_entry );                                  $feed->add_entry( $feed_entry );
1332                          }                          }
1333    
1334                    } elsif ( $show =~ m/^stat/ ) {
1335    
1336                            my $feed_entry = XML::Feed::Entry->new($type);
1337                            $feed_entry->title( "Internal stats" );
1338                            $feed_entry->content(
1339                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1340                            );
1341                            $feed->add_entry( $feed_entry );
1342    
1343                  } else {                  } else {
1344                          _log "unknown rss request ",$request->url;                          _log "WEB unknown rss request $r_url";
1345                          return RC_DENY;                          $feed->title( "unknown $r_url" );
1346                            foreach my $c ( @commands ) {
1347                                    my $feed_entry = XML::Feed::Entry->new($type);
1348                                    $feed_entry->title( "rss/$c" );
1349                                    $feed_entry->link( "$url/rss/$c" );
1350                                    $feed->add_entry( $feed_entry );
1351                            }
1352                            $rc = RC_DENY;
1353                  }                  }
1354    
1355                  $response->content( $feed->as_xml );                  $response->content( $feed->as_xml );
1356                  return RC_OK;                  return $rc;
1357          }          }
1358    
1359          if ( $@ ) {          if ( $@ ) {
# Line 1223  sub root_handler { Line 1444  sub root_handler {
1444          <p>See <a href="/history">history</a> of all messages.</p>          <p>See <a href="/history">history</a> of all messages.</p>
1445          </body></html>};          </body></html>};
1446    
1447          $response->content( $html );          $response->content( decode('utf-8',$html) );
1448          warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";          warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1449          return RC_OK;          return RC_OK;
1450  }  }
Legend:
Removed from v.92  
changed lines
  Added in v.125
  ViewVC Help
Powered by ViewVC 1.1.26