/[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 90 by dpavlin, Fri Mar 7 09:50:53 2008 UTC revision 122 by dpavlin, Fri Mar 14 14:37:46 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    
24  =head1 NAME  =head1 NAME
25    
26  irc-logger.pl  irc-logger.pl
# Line 30  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';
68  $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  
69  my $IRC_ALIAS = "log";  if ( $HOSTNAME =~ m/llin/ ) {
70            $irc_config->{nick} = 'irc-logger-llin';
71    #       $irc_config = {
72    #               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 ) if $debug;
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    
# Line 55  my $last_x_tags = 50; Line 96  my $last_x_tags = 50;
96    
97  # don't pull rss feeds more often than this  # don't pull rss feeds more often than this
98  my $rss_min_delay = 60;  my $rss_min_delay = 60;
 $rss_min_delay = 15;  
99    
100  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;  my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
101    
# Line 63  my $url = "http://$HOSTNAME:$http_port"; Line 103  my $url = "http://$HOSTNAME:$http_port";
103    
104  ## END CONFIG  ## END CONFIG
105    
 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;  
   
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 89  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            'debug!' => \$debug,
117  );  );
118    
119  #$SIG{__DIE__} = sub {  #$SIG{__DIE__} = sub {
120  #       confess "fatal error";  #       confess "fatal error";
121  #};  #};
122    
 open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  
   
123  sub _log {  sub _log {
124          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
125    }
126    
127    open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
128    
129    # queue
130    
131    if ( ! -d $queue_dir ) {
132            warn "## creating queue directory $queue_dir";
133            mkdir $queue_dir or die "can't create queue directory $queue_dir: $!";
134  }  }
135    
136    my $dq = IPC::DirQueue->new({ dir => $queue_dir });
137    
138  # HTML formatters  # HTML formatters
139    
140  my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
# Line 118  my $filter = { Line 152  my $filter = {
152                  # protect HTML from wiki modifications                  # protect HTML from wiki modifications
153                  sub e {                  sub e {
154                          my $t = shift;                          my $t = shift;
155                          return 'uri_unescape{' . uri_escape($t) . '}';                          return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
156                  }                  }
157    
158                  $m =~ s/($escape_re)/$escape{$1}/gs;                  $m =~ s/($escape_re)/$escape{$1}/gs;
159                  $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;
160                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;                  $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
161                  $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;
162                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;                  $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
# Line 143  my $filter = { Line 177  my $filter = {
177          },          },
178  };  };
179    
180    # POE IRC
181    my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
182            die "can't start ", dump( $irc_config ), ": $!";
183    
184    my $irc = $poe_irc->session_id();
185    _log "IRC session_id $irc";
186    
187  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
188  $dbh->do( qq{ set client_encoding = 'UTF-8' } );  $dbh->do( qq{ set client_encoding = 'UTF-8' } );
189    
# Line 179  create table feeds ( Line 220  create table feeds (
220          name text,          name text,
221          delay interval not null default '5 min',          delay interval not null default '5 min',
222          active boolean default true,          active boolean default true,
223            channel text not null,
224            nick text not null,
225            private boolean default false,
226          last_update timestamp default 'now()',          last_update timestamp default 'now()',
227          polls int default 0,          polls int default 0,
228          updates int default 0          updates int default 0
229  );  );
230  create unique index feeds_url on feeds(url);  create unique index feeds_url on feeds(url);
231  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');
232          },          },
233  };  };
234    
# Line 228  sub meta { Line 272  sub meta {
272                  if ( $@ || ! $sth->rows ) {                  if ( $@ || ! $sth->rows ) {
273                          $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()) });
274                          $sth->execute( $value, $nick, $channel, $name );                          $sth->execute( $value, $nick, $channel, $name );
275                          _log "created $nick/$channel/$name = $value";                          warn "## created $nick/$channel/$name = $value\n";
276                  } else {                  } else {
277                          _log "updated $nick/$channel/$name = $value ";                          warn "## updated $nick/$channel/$name = $value\n";
278                  }                  }
279    
280                  return $value;                  return $value;
# Line 240  sub meta { Line 284  sub meta {
284                  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 = ? });
285                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
286                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
287                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
288                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
289                  return $v;                  return $v;
290    
# Line 337  sub get_from_log { Line 381  sub get_from_log {
381    
382          my @where;          my @where;
383          my @args;          my @args;
384            my $msg;
385    
386          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
387                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
388                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
389                  push @where, 'message ilike ? or nick ilike ?';                  push @where, 'message ilike ? or nick ilike ?';
390                  push @args, ( ( '%' . $search . '%' ) x 2 );                  push @args, ( ( '%' . $search . '%' ) x 2 );
391                  _log "search for '$search'";                  $msg = "Search for '$search'";
392          }          }
393    
394          if ($args->{tag} && $tags->{ $args->{tag} }) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
395                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
396                  _log "search for tags $args->{tag}";                  $msg = "Search for tags $args->{tag}";
397          }          }
398    
399          if (my $date = $args->{date} ) {          if (my $date = $args->{date} ) {
400                  $date = check_date( $date );                  $date = check_date( $date );
401                  push @where, 'date(time) = ?';                  push @where, 'date(time) = ?';
402                  push @args, $date;                  push @args, $date;
403                  _log "search for date $date";                  $msg = "search for date $date";
404          }          }
405    
406          $sql .= " where " . join(" and ", @where) if @where;          $sql .= " where " . join(" and ", @where) if @where;
# Line 369  sub get_from_log { Line 414  sub get_from_log {
414          eval { $sth->execute( @args ) };          eval { $sth->execute( @args ) };
415          return if $@;          return if $@;
416    
417            my $nr_results = $sth->rows;
418    
419          my $last_row = {          my $last_row = {
420                  date => '',                  date => '',
421                  time => '',                  time => '',
# Line 389  sub get_from_log { Line 436  sub get_from_log {
436    
437          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
438    
439          my @msgs = (          $msg .= ' produced ' . (
440                  "Showing " . ($#rows + 1) . " messages..."                  $nr_results == 0 ? 'no results' :
441                    $nr_results == 0 ? 'one result' :
442                            $nr_results . ' results'
443          );          );
444    
445            my @msgs = ( $msg );
446    
447          if ($context) {          if ($context) {
448                  my @ids = @rows;                  my @ids = @rows;
449                  @rows = ();                  @rows = ();
# Line 449  sub get_from_log { Line 500  sub get_from_log {
500  #                       $row->{nick} = $nick;  #                       $row->{nick} = $nick;
501  #               }  #               }
502    
503                    $append = 0 if $row->{me};
504    
505                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
506                          # 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
507                          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 612  if ($import_dircproxy) { Line 665  if ($import_dircproxy) {
665  # RSS follow  # RSS follow
666  #  #
667    
668  my $_rss;  my $_stat;
669    
670    POE::Component::Client::HTTP->spawn(
671            Alias   => 'rss-fetch',
672            Timeout => 30,
673    );
674    
675  sub rss_fetch {  sub rss_parse_xml {
676          my ($args) = @_;          my ($args) = @_;
677    
678            warn "## rss_parse_xml ",dump( @_ ) if $debug;
679    
680          # 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?
681          my $send_rss_msgs = 1;          my $send_rss_msgs = 1;
682    
683          _log "RSS fetch", $args->{url};          _log "RSS fetch", $args->{url};
684    
685          my $feed = XML::Feed->parse(URI->new( $args->{url} ));          my $feed = XML::Feed->parse( \$args->{xml} );
686          if ( ! $feed ) {          if ( ! $feed ) {
687                  _log("can't fetch RSS ", $args->{url});                  _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
688                  return;                  return;
689          }          }
690    
691            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
692    
693          my ( $total, $updates ) = ( 0, 0 );          my ( $total, $updates ) = ( 0, 0 );
694          for my $entry ($feed->entries) {          for my $entry ($feed->entries) {
695                  $total++;                  $total++;
696    
697                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
698                  # seen allready?                  # seen allready?
699                  return if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;                  warn "## $seen_times ",$entry->id if $debug;
700                    next if $seen_times > 0;
701    
702                  sub prefix {                  sub prefix {
703                          my ($txt,$var) = @_;                          my ($txt,$var) = @_;
704                            $var =~ s/\s+/ /gs;
705                          $var =~ s/^\s+//g;                          $var =~ s/^\s+//g;
706                            $var =~ s/\s+$//g;
707                          return $txt . $var if $var;                          return $txt . $var if $var;
708                  }                  }
709    
710                    # fix absolute and relative links to feed entries
711                    my $link = $entry->link;
712                    if ( $link =~ m!^/! ) {
713                            my $host = $args->{url};
714                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
715                            $link = "$host/$link";
716                    } elsif ( $link !~ m!^http! ) {
717                            $link = $args->{url} . $link;
718                    }
719    
720                  my $msg;                  my $msg;
721                  $msg .= prefix( 'From: ' , $args->{name} || $feed->title );                  $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
722                  $msg .= prefix( ' by ' , $entry->author );                  $msg .= prefix( ' by ' , $entry->author );
723                  $msg .= prefix( ' -- ' , $entry->link );                  $msg .= prefix( ' | ' , $entry->title );
724                    $msg .= prefix( ' | ' , $link );
725  #               $msg .= prefix( ' id ' , $entry->id );  #               $msg .= prefix( ' id ' , $entry->id );
726                    if ( my $tags = $entry->category ) {
727                            $tags =~ s!^\s+!!;
728                            $tags =~ s!\s*$! !;
729                            $tags =~ s!,?\s+!// !g;
730                            $msg .= prefix( ' ' , $tags );
731                    }
732    
733                  if ( $args->{kernel} && $send_rss_msgs ) {                  if ( $seen_times == 0 && $send_rss_msgs ) {
734                          $send_rss_msgs--;                          $send_rss_msgs--;
735                          _log('RSS', $msg);                          if ( ! $args->{private} ) {
736                          $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, undef );                                  # FIXME bug! should be save_message
737                          $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );                                  save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
738    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
739                            }
740                            my ( $type, $to ) = ( 'notice', $args->{channel} );
741                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
742    
743                            _log("RSS generated $type to $to:", $msg);
744                            # XXX enqueue message to send later
745                            sub enqueue_post {
746                                    my $post = dump( @_ );
747                                    warn "## queue_post $post\n" if $debug;
748                                    $dq->enqueue_string( $post );
749                            }
750                            enqueue_post( $type => $to => $msg );
751    
752                          $updates++;                          $updates++;
753                  }                  }
754          }          }
# Line 669  sub rss_fetch { Line 766  sub rss_fetch {
766  sub rss_fetch_all {  sub rss_fetch_all {
767          my $kernel = shift;          my $kernel = shift;
768          my $sql = qq{          my $sql = qq{
769                  select id, url, name                  select id, url, name, channel, nick, private
770                  from feeds                  from feeds
771                  where active is true                  where active is true
772          };          };
773          # limit to newer feeds only if we are not sending messages out          # limit to newer feeds only if we are not sending messages out
774          $sql .= qq{     and last_update + delay < now() } if $kernel;          $sql .= qq{     and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
775          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
776          $sth->execute();          $sth->execute();
777          warn "# ",$sth->rows," active RSS feeds\n";          warn "# ",$sth->rows," active RSS feeds\n";
778          my $count = 0;          my $count = 0;
779          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
780                  $row->{kernel} = $kernel if $kernel;                  warn "## queued rss-fetch for ", $row->{url} if $debug;
781                  $count += rss_fetch( $row );                  $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
782                    $kernel->post(
783                            'rss-fetch',
784                            'request',
785                            'rss_response',
786                            HTTP::Request->new( GET => $row->{url} ),
787                    );
788          }          }
789          return "OK, fetched $count posts from " . $sth->rows . " feeds";          return "OK, scheduled " . $sth->rows . " feeds for refresh";
790  }  }
791    
792    
793  sub rss_check_updates {  sub rss_check_updates {
794          my $kernel = shift;          my $kernel = shift;
795          my $last_t = $_rss->{last_poll} || time();          $_stat->{rss}->{last_poll} ||= time();
796          my $t = time();          my $dt = time() - $_stat->{rss}->{last_poll};
797          if ( $t - $last_t > $rss_min_delay ) {          if ( $dt > $rss_min_delay ) {
798                  $_rss->{last_poll} = $t;                  warn "## rss_check_updates $dt > $rss_min_delay\n";
799                    $_stat->{rss}->{last_poll} = time();
800                  _log rss_fetch_all( $kernel );                  _log rss_fetch_all( $kernel );
801          }          }
802            # XXX send queue messages
803            while ( my $job = $dq->pickup_queued_job() ) {
804                    my $data = read_file( $job->get_data_path ) || die "can't load ", $job->get_data_path, ": $!";
805    #               $kernel->post( $irc => $type => $to, $msg );
806                    my @data = eval $data;
807                    _log "IRC post from queue:", @data;
808                    $kernel->post( $irc => @data );
809                    $job->finish;
810                    warn "## done queued job: ",dump( @data ) if $debug;
811            }
812  }  }
813    
 # 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);  
   
814  POE::Session->create( inline_states => {  POE::Session->create( inline_states => {
815          _start => sub {                _start => sub {      
816                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post( $irc => register => 'all' );
817                  $_[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" );  
818      },      },
819            irc_001 => sub {
820                    my ($kernel,$sender) = @_[KERNEL,SENDER];
821                    my $poco_object = $sender->get_heap();
822                    _log "connected to",$poco_object->server_name();
823                    $kernel->post( $sender => join => $_ ) for @channels;
824                    # seen RSS cache
825                    _log rss_fetch_all( $kernel );
826                    undef;
827            },
828    #       irc_255 => sub {        # server is done blabbing
829    #               $_[KERNEL]->post( $irc => join => $CHANNEL);
830    #       },
831      irc_public => sub {      irc_public => sub {
832                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
833                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
# Line 725  POE::Session->create( inline_states => { Line 836  POE::Session->create( inline_states => {
836    
837                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
838                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
839                    rss_check_updates( $kernel );
840      },      },
841      irc_ctcp_action => sub {      irc_ctcp_action => sub {
842                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 746  POE::Session->create( inline_states => { Line 858  POE::Session->create( inline_states => {
858      },      },
859          irc_ping => sub {          irc_ping => sub {
860                  _log( "pong ", $_[ARG0] );                  _log( "pong ", $_[ARG0] );
861                  $ping->{ $_[ARG0] }++;                  $_stat->{ping}->{ $_[ARG0] }++;
862                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
863          },          },
864          irc_invite => sub {          irc_invite => sub {
# Line 756  POE::Session->create( inline_states => { Line 868  POE::Session->create( inline_states => {
868    
869                  _log "invited to $channel by $nick";                  _log "invited to $channel by $nick";
870    
871                  $_[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..." );
872                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post( $irc => 'join' => $channel );
873    
874          },          },
875          irc_msg => sub {          irc_msg => sub {
# Line 765  POE::Session->create( inline_states => { Line 877  POE::Session->create( inline_states => {
877                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
878                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
879                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
880                    warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
881    
882                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
883                  my @out;                  my @out;
# Line 775  POE::Session->create( inline_states => { Line 888  POE::Session->create( inline_states => {
888    
889                          $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";
890    
891                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
892    
893                          _log ">> /msg $1 $2";                          _log ">> /$1 $2 $3";
894                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $irc => $1 => $2, $3 );
895                          $res = '';                          $res = '';
896    
897                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
# Line 808  POE::Session->create( inline_states => { Line 921  POE::Session->create( inline_states => {
921    
922                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
923                                  _log "last: $res";                                  _log "last: $res";
924                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
925                          }                          }
926    
927                          $res = '';                          $res = '';
# Line 822  POE::Session->create( inline_states => { Line 935  POE::Session->create( inline_states => {
935                                          search => $what,                                          search => $what,
936                                  )) {                                  )) {
937                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
938                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
939                          }                          }
940    
941                          $res = '';                          $res = '';
# Line 857  POE::Session->create( inline_states => { Line 970  POE::Session->create( inline_states => {
970                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
971                                  " from " . ( join(", ", @nicks) || 'nobody' );                                  " from " . ( join(", ", @nicks) || 'nobody' );
972    
973                          $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );                          $_[KERNEL]->post( $irc => notice => $nick, $res );
974    
975                  } elsif ($msg =~ m/^ping/) {                  } elsif ($msg =~ m/^ping/) {
976                          $res = "ping = " . dump( $ping );                          $res = "ping = " . dump( $_stat->{ping} );
977                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
978                          if ( ! defined( $1 ) ) {                          if ( ! defined( $1 ) ) {
979                                  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 893  POE::Session->create( inline_states => { Line 1006  POE::Session->create( inline_states => {
1006                          }                          }
1007                  } elsif ($msg =~ m/^rss-update/) {                  } elsif ($msg =~ m/^rss-update/) {
1008                          $res = rss_fetch_all( $_[KERNEL] );                          $res = rss_fetch_all( $_[KERNEL] );
1009                  } elsif ($msg =~ m/^rss-clean/) {                  } elsif ($msg =~ m/^rss-list/) {
1010                          $_rss = undef;                          my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
1011                          $dbh->do( qq{ update feeds set last_update = now() - delay } );                          $sth->execute;
1012                          $res = "OK, cleaned RSS cache";                          while (my @row = $sth->fetchrow_array) {
1013                  } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {                                  $_[KERNEL]->post( $irc => privmsg => $nick, join(' | ',@row) );
1014                            }
1015                            $res = '';
1016                    } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
1017                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
1018    
1019                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
1020                            $channel = $nick if $sub eq 'private';
1021    
1022                          my $sql = {                          my $sql = {
1023                                  add             => qq{ insert into feeds (url,name) values (?,?) },                                  add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
1024  #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },  #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
1025                                  start   => qq{ update feeds set active = true   where url = ? -- ? },                                  start   => qq{ update feeds set active = true   where url = ? },
1026                                  stop    => qq{ update feeds set active = false  where url = ? -- ? },                                  stop    => qq{ update feeds set active = false  where url = ? },
1027                                                                    clean   => qq{ update feeds set last_update = now() - delay where url = ? },
1028                          };                          };
1029                          if (my $q = $sql->{$1} ) {  
1030                            if ( $command eq 'add' && ! $channel ) {
1031                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
1032                            } elsif (my $q = $sql->{$command} ) {
1033                                  my $sth = $dbh->prepare( $q );                                  my $sth = $dbh->prepare( $q );
1034                                  warn "## SQL $q ( $2 | $3 )\n";                                  my @data = ( $url );
1035                                  eval { $sth->execute( $2, $3 ) };                                  if ( $command eq 'add' ) {
1036                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
1037                                    }
1038                                    warn "## $command SQL $q with ",dump( @data ),"\n";
1039                                    eval { $sth->execute( @data ) };
1040                                    if ($@) {
1041                                            $res = "ERROR: $@";
1042                                    } else {
1043                                            $res = "OK, RSS executed $command " . ( $sub ? "-$sub" : '' ) ."on $channel url $url";
1044                                            if ( $command eq 'clean' ) {
1045                                                    my $seen = $_stat->{rss}->{seen} || die "no seen?";
1046                                                    my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
1047                                                    foreach my $c ( keys %$seen ) {
1048                                                            my $c_hash = $seen->{$c} || die "no seen->{$c}";
1049                                                            die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
1050                                                            foreach my $link ( keys %$c_hash ) {
1051                                                                    next unless $link eq $want_link;
1052                                                                    _log "RSS removed seen $c $url $link";
1053                                                            }
1054                                                    }
1055                                            }
1056                                    }
1057                            } else {
1058                                    $res = "ERROR: don't know what to do with: $msg";
1059                          }                          }
1060                    } elsif ($msg =~ m/^rss-clean/) {
1061                          $res = "OK, RSS $1 : $2 - $3";                          # this makes sense because we didn't catch rss-clean http://... before!
1062                            $_stat->{rss} = undef;
1063                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
1064                            $res = "OK, cleaned RSS cache";
1065                  }                  }
1066    
1067                  if ($res) {                  if ($res) {
1068                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
1069                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1070                  }                  }
1071    
1072                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
1073          },          },
1074            irc_372 => sub {
1075                    _log "<< motd",$_[ARG0],$_[ARG1];
1076            },
1077            irc_375 => sub {
1078                    _log "<< motd", $_[ARG0], "start";
1079            },
1080            irc_376 => sub {
1081                    _log "<< motd", $_[ARG0], "end";
1082            },
1083    #       irc_433 => sub {
1084    #               print "# irc_433: ",$_[ARG1], "\n";
1085    #               warn "## indetify $NICK\n";
1086    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1087    #       },
1088    #       irc_451 # please register
1089          irc_477 => sub {          irc_477 => sub {
1090                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
1091                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> IDENTIFY $NICK";
1092                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1093          },          },
1094          irc_505 => sub {          irc_505 => sub {
1095                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
1096                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> register $NICK";
1097  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );                  $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1098  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1099    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1100    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1101          },          },
1102          irc_registered => sub {          irc_registered => sub {
1103                  _log "## registrated $NICK";                  _log "<< registered $NICK";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1104          },          },
1105          irc_disconnected => sub {          irc_disconnected => sub {
1106                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1107                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1108                    $_[KERNEL]->post( $irc => connect => {} );
1109          },          },
1110          irc_socketerr => sub {          irc_socketerr => sub {
1111                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1112                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1113                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
1114            },
1115            irc_notice => sub {
1116                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1117                    my $m = $_[ARG2];
1118                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1119                            _log ">> suggested to $1 $2";
1120                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1121                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1122                            _log ">> registreted, so IDENTIFY";
1123                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1124                    } else {
1125                            warn "## ignore $m\n" if $debug;
1126                    }
1127            },
1128            irc_snotice => sub {
1129                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1130                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1131                            warn ">> $1 | $2\n";
1132                            $_[KERNEL]->post( $irc => lc($1) => $2);
1133                    }
1134          },          },
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
1135      _child => sub {},      _child => sub {},
1136      _default => sub {      _default => sub {
1137                  _log sprintf "sID:%s %s %s",                  _log sprintf "sID:%s %s %s",
# Line 958  POE::Session->create( inline_states => { Line 1141  POE::Session->create( inline_states => {
1141                          "";                          "";
1142        0;                        # false for signals        0;                        # false for signals
1143      },      },
1144            rss_response => sub {
1145                    my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1146                    my $request_object  = $request_packet->[0];
1147                    my $response_object = $response_packet->[0];
1148    
1149                    my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1150                    if ( $row ) {
1151                            $row->{xml} = $response_object->content;
1152                            rss_parse_xml( $row );
1153                    } else {
1154                            warn "## can't find rss->fetch for ", $request_object->uri;
1155                    }
1156            },
1157     },     },
1158    );    );
1159    
1160  # http server  # http server
1161    
1162    _log "WEB archive at $url";
1163    
1164  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1165          Port => $http_port,          Port => $http_port,
1166          PreHandler => {          PreHandler => {
# Line 1009  foreach my $c (@cols) { Line 1207  foreach my $c (@cols) {
1207          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1208          $max_color++;          $max_color++;
1209  }  }
1210  warn "defined $max_color colors for users...\n";  _log "WEB defined $max_color colors for users...";
1211    
1212  sub root_handler {  sub root_handler {
1213          my ($request, $response) = @_;          my ($request, $response) = @_;
# Line 1031  sub root_handler { Line 1229  sub root_handler {
1229          }          }
1230    
1231          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1232            my $r_url = $request->url;
1233    
1234          if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {          my @commands = qw( tags last-tag follow stat );
1235            my $commands_re = join('|',@commands);
1236    
1237            if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1238                  my $show = lc($1);                  my $show = lc($1);
1239                  my $nr = $2;                  my $nr = $2;
1240    
# Line 1046  sub root_handler { Line 1248  sub root_handler {
1248                  my $feed = XML::Feed->new( $type );                  my $feed = XML::Feed->new( $type );
1249                  $feed->link( $url );                  $feed->link( $url );
1250    
1251                    my $rc = RC_OK;
1252    
1253                  if ( $show eq 'tags' ) {                  if ( $show eq 'tags' ) {
1254                          $nr ||= 50;                          $nr ||= 50;
1255                          $feed->title( "tags from $CHANNEL" );                          $feed->title( "tags from $CHANNEL" );
# Line 1115  sub root_handler { Line 1319  sub root_handler {
1319                                  $feed->add_entry( $feed_entry );                                  $feed->add_entry( $feed_entry );
1320                          }                          }
1321    
1322                    } elsif ( $show =~ m/^stat/ ) {
1323    
1324                            my $feed_entry = XML::Feed::Entry->new($type);
1325                            $feed_entry->title( "Internal stats" );
1326                            $feed_entry->content(
1327                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1328                            );
1329                            $feed->add_entry( $feed_entry );
1330    
1331                  } else {                  } else {
1332                          _log "unknown rss request ",$request->url;                          _log "WEB unknown rss request $r_url";
1333                          return RC_DENY;                          $feed->title( "unknown $r_url" );
1334                            foreach my $c ( @commands ) {
1335                                    my $feed_entry = XML::Feed::Entry->new($type);
1336                                    $feed_entry->title( "rss/$c" );
1337                                    $feed_entry->link( "$url/rss/$c" );
1338                                    $feed->add_entry( $feed_entry );
1339                            }
1340                            $rc = RC_DENY;
1341                  }                  }
1342    
1343                  $response->content( $feed->as_xml );                  $response->content( $feed->as_xml );
1344                  return RC_OK;                  return $rc;
1345          }          }
1346    
1347          if ( $@ ) {          if ( $@ ) {
Legend:
Removed from v.90  
changed lines
  Added in v.122
  ViewVC Help
Powered by ViewVC 1.1.26