/[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 93 by dpavlin, Fri Mar 7 10:35:04 2008 UTC revision 123 by dpavlin, Fri Mar 14 14:45:04 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 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  sub rss_fetch {  sub rss_parse_xml {
677          my ($args) = @_;          my ($args) = @_;
678    
679            warn "## rss_parse_xml ",dump( @_ ) if $debug;
680    
681          # 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?
682          my $send_rss_msgs = 1;          my $send_rss_msgs = 1;
683    
684          _log "RSS fetch", $args->{url};          _log "RSS fetch", $args->{url};
685    
686          my $feed = XML::Feed->parse(URI->new( $args->{url} ));          my $feed = XML::Feed->parse( \$args->{xml} );
687          if ( ! $feed ) {          if ( ! $feed ) {
688                  _log("can't fetch RSS ", $args->{url});                  _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
689                  return;                  return;
690          }          }
691    
692            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
693    
694          my ( $total, $updates ) = ( 0, 0 );          my ( $total, $updates ) = ( 0, 0 );
695          for my $entry ($feed->entries) {          for my $entry ($feed->entries) {
696                  $total++;                  $total++;
697    
698                    my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
699                  # seen allready?                  # seen allready?
700                  next if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;                  warn "## $seen_times ",$entry->id if $debug;
701                    next if $seen_times > 0;
702    
703                  sub prefix {                  sub prefix {
704                          my ($txt,$var) = @_;                          my ($txt,$var) = @_;
# Line 644  sub rss_fetch { Line 708  sub rss_fetch {
708                          return $txt . $var if $var;                          return $txt . $var if $var;
709                  }                  }
710    
711                    # fix absolute and relative links to feed entries
712                    my $link = $entry->link;
713                    if ( $link =~ m!^/! ) {
714                            my $host = $args->{url};
715                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
716                            $link = "$host/$link";
717                    } elsif ( $link !~ m!^http! ) {
718                            $link = $args->{url} . $link;
719                    }
720    
721                  my $msg;                  my $msg;
722                  $msg .= prefix( 'From: ' , $args->{name} || $feed->title );                  $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
723                  $msg .= prefix( ' by ' , $entry->author );                  $msg .= prefix( ' by ' , $entry->author );
724                  $msg .= prefix( ' | ' , $entry->title );                  $msg .= prefix( ' | ' , $entry->title );
725                  $msg .= prefix( ' | ' , $entry->link );                  $msg .= prefix( ' | ' , $link );
726  #               $msg .= prefix( ' id ' , $entry->id );  #               $msg .= prefix( ' id ' , $entry->id );
727                    if ( my $tags = $entry->category ) {
728                            $tags =~ s!^\s+!!;
729                            $tags =~ s!\s*$! !;
730                            $tags =~ s!,?\s+!// !g;
731                            $msg .= prefix( ' ' , $tags );
732                    }
733    
734                  if ( $args->{kernel} && $send_rss_msgs ) {                  if ( $seen_times == 0 && $send_rss_msgs ) {
735                          $send_rss_msgs--;                          $send_rss_msgs--;
736                          _log('>>', $msg);                          if ( ! $args->{private} ) {
737                          $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, 'now()' );                                  # FIXME bug! should be save_message
738                          $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );                                  save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
739    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
740                            }
741                            my ( $type, $to ) = ( 'notice', $args->{channel} );
742                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
743    
744                            _log("RSS generated $type to $to:", $msg);
745                            # XXX enqueue message to send later
746                            sub enqueue_post {
747                                    my $post = dump( @_ );
748                                    warn "## queue_post $post\n" if $debug;
749                                    $dq->enqueue_string( $post );
750                            }
751                            enqueue_post( $type => $to => $msg );
752    
753                          $updates++;                          $updates++;
754                  }                  }
755          }          }
# Line 673  sub rss_fetch { Line 767  sub rss_fetch {
767  sub rss_fetch_all {  sub rss_fetch_all {
768          my $kernel = shift;          my $kernel = shift;
769          my $sql = qq{          my $sql = qq{
770                  select id, url, name                  select id, url, name, channel, nick, private
771                  from feeds                  from feeds
772                  where active is true                  where active is true
773          };          };
774          # limit to newer feeds only if we are not sending messages out          # limit to newer feeds only if we are not sending messages out
775          $sql .= qq{     and last_update + delay < now() } if $kernel;          $sql .= qq{     and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
776          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
777          $sth->execute();          $sth->execute();
778          warn "# ",$sth->rows," active RSS feeds\n";          warn "# ",$sth->rows," active RSS feeds\n";
779          my $count = 0;          my $count = 0;
780          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
781                  $row->{kernel} = $kernel if $kernel;                  warn "## queued rss-fetch for ", $row->{url} if $debug;
782                  $count += rss_fetch( $row );                  $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
783                    $kernel->post(
784                            'rss-fetch',
785                            'request',
786                            'rss_response',
787                            HTTP::Request->new( GET => $row->{url} ),
788                    );
789          }          }
790          return "OK, fetched $count posts from " . $sth->rows . " feeds";          return "OK, scheduled " . $sth->rows . " feeds for refresh";
791  }  }
792    
793    
794  sub rss_check_updates {  sub rss_check_updates {
795          my $kernel = shift;          my $kernel = shift;
796          my $last_t = $_rss->{last_poll} || time();          $_stat->{rss}->{last_poll} ||= time();
797          my $t = time();          my $dt = time() - $_stat->{rss}->{last_poll};
798          if ( $t - $last_t > $rss_min_delay ) {          if ( $dt > $rss_min_delay ) {
799                  $_rss->{last_poll} = $t;                  warn "## rss_check_updates $dt > $rss_min_delay\n";
800                    $_stat->{rss}->{last_poll} = time();
801                  _log rss_fetch_all( $kernel );                  _log rss_fetch_all( $kernel );
802          }          }
803            # XXX send queue messages
804            while ( my $job = $dq->pickup_queued_job() ) {
805                    my $data = read_file( $job->get_data_path ) || die "can't load ", $job->get_data_path, ": $!";
806    #               $kernel->post( $irc => $type => $to, $msg );
807                    my @data = eval $data;
808                    _log "IRC post from queue:", @data;
809                    $kernel->post( $irc => @data );
810                    $job->finish;
811                    warn "## done queued job: ",dump( @data ) if $debug;
812            }
813  }  }
814    
 # 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);  
   
815  POE::Session->create( inline_states => {  POE::Session->create( inline_states => {
816          _start => sub {                _start => sub {      
817                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post( $irc => register => 'all' );
818                  $_[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" );  
819      },      },
820            irc_001 => sub {
821                    my ($kernel,$sender) = @_[KERNEL,SENDER];
822                    my $poco_object = $sender->get_heap();
823                    _log "connected to",$poco_object->server_name();
824                    $kernel->post( $sender => join => $_ ) for @channels;
825                    # seen RSS cache
826                    _log rss_fetch_all( $kernel );
827                    undef;
828            },
829    #       irc_255 => sub {        # server is done blabbing
830    #               $_[KERNEL]->post( $irc => join => $CHANNEL);
831    #       },
832      irc_public => sub {      irc_public => sub {
833                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
834                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
# Line 729  POE::Session->create( inline_states => { Line 837  POE::Session->create( inline_states => {
837    
838                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
839                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
840                    rss_check_updates( $kernel );
841      },      },
842      irc_ctcp_action => sub {      irc_ctcp_action => sub {
843                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 750  POE::Session->create( inline_states => { Line 859  POE::Session->create( inline_states => {
859      },      },
860          irc_ping => sub {          irc_ping => sub {
861                  _log( "pong ", $_[ARG0] );                  _log( "pong ", $_[ARG0] );
862                  $ping->{ $_[ARG0] }++;                  $_stat->{ping}->{ $_[ARG0] }++;
863                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
864          },          },
865          irc_invite => sub {          irc_invite => sub {
# Line 760  POE::Session->create( inline_states => { Line 869  POE::Session->create( inline_states => {
869    
870                  _log "invited to $channel by $nick";                  _log "invited to $channel by $nick";
871    
872                  $_[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..." );
873                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post( $irc => 'join' => $channel );
874    
875          },          },
876          irc_msg => sub {          irc_msg => sub {
# Line 769  POE::Session->create( inline_states => { Line 878  POE::Session->create( inline_states => {
878                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
879                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
880                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
881                    warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
882    
883                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
884                  my @out;                  my @out;
# Line 779  POE::Session->create( inline_states => { Line 889  POE::Session->create( inline_states => {
889    
890                          $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";
891    
892                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
893    
894                          _log ">> /msg $1 $2";                          _log ">> /$1 $2 $3";
895                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $irc => $1 => $2, $3 );
896                          $res = '';                          $res = '';
897    
898                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
# Line 812  POE::Session->create( inline_states => { Line 922  POE::Session->create( inline_states => {
922    
923                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
924                                  _log "last: $res";                                  _log "last: $res";
925                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
926                          }                          }
927    
928                          $res = '';                          $res = '';
# Line 826  POE::Session->create( inline_states => { Line 936  POE::Session->create( inline_states => {
936                                          search => $what,                                          search => $what,
937                                  )) {                                  )) {
938                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
939                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
940                          }                          }
941    
942                          $res = '';                          $res = '';
# Line 861  POE::Session->create( inline_states => { Line 971  POE::Session->create( inline_states => {
971                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
972                                  " from " . ( join(", ", @nicks) || 'nobody' );                                  " from " . ( join(", ", @nicks) || 'nobody' );
973    
974                          $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );                          $_[KERNEL]->post( $irc => notice => $nick, $res );
975    
976                  } elsif ($msg =~ m/^ping/) {                  } elsif ($msg =~ m/^ping/) {
977                          $res = "ping = " . dump( $ping );                          $res = "ping = " . dump( $_stat->{ping} );
978                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
979                          if ( ! defined( $1 ) ) {                          if ( ! defined( $1 ) ) {
980                                  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 897  POE::Session->create( inline_states => { Line 1007  POE::Session->create( inline_states => {
1007                          }                          }
1008                  } elsif ($msg =~ m/^rss-update/) {                  } elsif ($msg =~ m/^rss-update/) {
1009                          $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";  
1010                  } elsif ($msg =~ m/^rss-list/) {                  } elsif ($msg =~ m/^rss-list/) {
1011                          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 });
1012                          $sth->execute;                          $sth->execute;
1013                          while (my @row = $sth->fetchrow_array) {                          while (my @row = $sth->fetchrow_array) {
1014                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );                                  $_[KERNEL]->post( $irc => privmsg => $nick, join(' | ',@row) );
1015                          }                          }
1016                          $res = '';                          $res = '';
1017                  } 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*(.*)!) {
1018                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
1019    
1020                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
1021                            $channel = $nick if $sub eq 'private';
1022    
1023                          my $sql = {                          my $sql = {
1024                                  add             => qq{ insert into feeds (url,name) values (?,?) },                                  add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
1025  #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },  #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
1026                                  start   => qq{ update feeds set active = true   where url = ? },                                  start   => qq{ update feeds set active = true   where url = ? },
1027                                  stop    => qq{ update feeds set active = false  where url = ? },                                  stop    => qq{ update feeds set active = false  where url = ? },
1028                                                                    clean   => qq{ update feeds set last_update = now() - delay where url = ? },
1029                          };                          };
1030                          if (my $q = $sql->{$1} ) {  
1031                            if ( $command eq 'add' && ! $channel ) {
1032                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
1033                            } elsif (my $q = $sql->{$command} ) {
1034                                  my $sth = $dbh->prepare( $q );                                  my $sth = $dbh->prepare( $q );
1035                                  my @data = ( $2 );                                  my @data = ( $url );
1036                                  push @data, $3 if ( $q =~ s/\?//g == 2 );                                  if ( $command eq 'add' ) {
1037                                  warn "## $1 SQL $q with ",dump( @data ),"\n";                                          push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
1038                                    }
1039                                    warn "## $command SQL $q with ",dump( @data ),"\n";
1040                                  eval { $sth->execute( @data ) };                                  eval { $sth->execute( @data ) };
1041                                    if ($@) {
1042                                            $res = "ERROR: $@";
1043                                    } else {
1044                                            $res = "OK, RSS executed $command " . ( $sub ? "-$sub" : '' ) ."on $channel url $url";
1045                                            if ( $command eq 'clean' ) {
1046                                                    my $seen = $_stat->{rss}->{seen} || die "no seen?";
1047                                                    my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
1048                                                    foreach my $c ( keys %$seen ) {
1049                                                            my $c_hash = $seen->{$c} || die "no seen->{$c}";
1050                                                            die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
1051                                                            foreach my $link ( keys %$c_hash ) {
1052                                                                    next unless $link eq $want_link;
1053                                                                    _log "RSS removed seen $c $url $link";
1054                                                            }
1055                                                    }
1056                                            }
1057                                    }
1058                            } else {
1059                                    $res = "ERROR: don't know what to do with: $msg";
1060                          }                          }
1061                    } elsif ($msg =~ m/^rss-clean/) {
1062                          $res = "OK, RSS $1 : $2 - $3";                          # this makes sense because we didn't catch rss-clean http://... before!
1063                            $_stat->{rss} = undef;
1064                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
1065                            $res = "OK, cleaned RSS cache";
1066                  }                  }
1067    
1068                  if ($res) {                  if ($res) {
1069                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
1070                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1071                  }                  }
1072    
1073                  rss_check_updates( $_[KERNEL] );                  rss_check_updates( $_[KERNEL] );
1074          },          },
1075            irc_372 => sub {
1076                    _log "<< motd",$_[ARG0],$_[ARG1];
1077            },
1078            irc_375 => sub {
1079                    _log "<< motd", $_[ARG0], "start";
1080            },
1081            irc_376 => sub {
1082                    _log "<< motd", $_[ARG0], "end";
1083            },
1084    #       irc_433 => sub {
1085    #               print "# irc_433: ",$_[ARG1], "\n";
1086    #               warn "## indetify $NICK\n";
1087    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1088    #       },
1089    #       irc_451 # please register
1090          irc_477 => sub {          irc_477 => sub {
1091                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
1092                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> IDENTIFY $NICK";
1093                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1094          },          },
1095          irc_505 => sub {          irc_505 => sub {
1096                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
1097                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> register $NICK";
1098  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );                  $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1099  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1100    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1101    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1102          },          },
1103          irc_registered => sub {          irc_registered => sub {
1104                  _log "## registrated $NICK";                  _log "<< registered $NICK";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1105          },          },
1106          irc_disconnected => sub {          irc_disconnected => sub {
1107                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1108                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1109                    $_[KERNEL]->post( $irc => connect => {} );
1110          },          },
1111          irc_socketerr => sub {          irc_socketerr => sub {
1112                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1113                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1114                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
1115            },
1116            irc_notice => sub {
1117                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1118                    my $m = $_[ARG2];
1119                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1120                            _log ">> suggested to $1 $2";
1121                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1122                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1123                            _log ">> registreted, so IDENTIFY";
1124                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1125                    } else {
1126                            warn "## ignore $m\n" if $debug;
1127                    }
1128            },
1129            irc_snotice => sub {
1130                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1131                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1132                            warn ">> $1 | $2\n";
1133                            $_[KERNEL]->post( $irc => lc($1) => $2);
1134                    }
1135          },          },
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
1136      _child => sub {},      _child => sub {},
1137      _default => sub {      _default => sub {
1138                  _log sprintf "sID:%s %s %s",                  _log sprintf "sID:%s %s %s",
# Line 971  POE::Session->create( inline_states => { Line 1142  POE::Session->create( inline_states => {
1142                          "";                          "";
1143        0;                        # false for signals        0;                        # false for signals
1144      },      },
1145            rss_response => sub {
1146                    my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1147                    my $request_object  = $request_packet->[0];
1148                    my $response_object = $response_packet->[0];
1149    
1150                    my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1151                    if ( $row ) {
1152                            $row->{xml} = $response_object->content;
1153                            rss_parse_xml( $row );
1154                    } else {
1155                            warn "## can't find rss->fetch for ", $request_object->uri;
1156                    }
1157            },
1158     },     },
1159    );    );
1160    
1161  # http server  # http server
1162    
1163    _log "WEB archive at $url";
1164    
1165  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1166          Port => $http_port,          Port => $http_port,
1167          PreHandler => {          PreHandler => {
# Line 1022  foreach my $c (@cols) { Line 1208  foreach my $c (@cols) {
1208          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1209          $max_color++;          $max_color++;
1210  }  }
1211  warn "defined $max_color colors for users...\n";  _log "WEB defined $max_color colors for users...";
1212    
1213  sub root_handler {  sub root_handler {
1214          my ($request, $response) = @_;          my ($request, $response) = @_;
# Line 1044  sub root_handler { Line 1230  sub root_handler {
1230          }          }
1231    
1232          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1233            my $r_url = $request->url;
1234    
1235          if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {          my @commands = qw( tags last-tag follow stat );
1236            my $commands_re = join('|',@commands);
1237    
1238            if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1239                  my $show = lc($1);                  my $show = lc($1);
1240                  my $nr = $2;                  my $nr = $2;
1241    
# Line 1059  sub root_handler { Line 1249  sub root_handler {
1249                  my $feed = XML::Feed->new( $type );                  my $feed = XML::Feed->new( $type );
1250                  $feed->link( $url );                  $feed->link( $url );
1251    
1252                    my $rc = RC_OK;
1253    
1254                  if ( $show eq 'tags' ) {                  if ( $show eq 'tags' ) {
1255                          $nr ||= 50;                          $nr ||= 50;
1256                          $feed->title( "tags from $CHANNEL" );                          $feed->title( "tags from $CHANNEL" );
# Line 1128  sub root_handler { Line 1320  sub root_handler {
1320                                  $feed->add_entry( $feed_entry );                                  $feed->add_entry( $feed_entry );
1321                          }                          }
1322    
1323                    } elsif ( $show =~ m/^stat/ ) {
1324    
1325                            my $feed_entry = XML::Feed::Entry->new($type);
1326                            $feed_entry->title( "Internal stats" );
1327                            $feed_entry->content(
1328                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1329                            );
1330                            $feed->add_entry( $feed_entry );
1331    
1332                  } else {                  } else {
1333                          _log "unknown rss request ",$request->url;                          _log "WEB unknown rss request $r_url";
1334                          return RC_DENY;                          $feed->title( "unknown $r_url" );
1335                            foreach my $c ( @commands ) {
1336                                    my $feed_entry = XML::Feed::Entry->new($type);
1337                                    $feed_entry->title( "rss/$c" );
1338                                    $feed_entry->link( "$url/rss/$c" );
1339                                    $feed->add_entry( $feed_entry );
1340                            }
1341                            $rc = RC_DENY;
1342                  }                  }
1343    
1344                  $response->content( $feed->as_xml );                  $response->content( $feed->as_xml );
1345                  return RC_OK;                  return $rc;
1346          }          }
1347    
1348          if ( $@ ) {          if ( $@ ) {
# Line 1225  sub root_handler { Line 1433  sub root_handler {
1433          <p>See <a href="/history">history</a> of all messages.</p>          <p>See <a href="/history">history</a> of all messages.</p>
1434          </body></html>};          </body></html>};
1435    
1436          $response->content( $html );          $response->content( decode('utf-8',$html) );
1437          warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";          warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1438          return RC_OK;          return RC_OK;
1439  }  }
Legend:
Removed from v.93  
changed lines
  Added in v.123
  ViewVC Help
Powered by ViewVC 1.1.26