/[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 53 by dpavlin, Sun Mar 18 17:00:16 2007 UTC revision 85 by dpavlin, Thu Mar 6 22:16:27 2008 UTC
# Line 22  Import log from C<dircproxy> to C<irc-lo Line 22  Import log from C<dircproxy> to C<irc-lo
22    
23  Name of log file  Name of log file
24    
25    =item --follow=file.log
26    
27    Follows new messages in file
28    
29  =back  =back
30    
31  =head1 DESCRIPTION  =head1 DESCRIPTION
# Line 32  log all conversation on irc channel Line 36  log all conversation on irc channel
36    
37  ## CONFIG  ## CONFIG
38    
39  my $HOSTNAME = `hostname`;  my $HOSTNAME = `hostname -f`;
40    chomp($HOSTNAME);
41    
42  my $NICK = 'irc-logger';  my $NICK = 'irc-logger';
43  $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
# Line 45  my $CHANNEL = '#razmjenavjestina'; Line 50  my $CHANNEL = '#razmjenavjestina';
50  $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
51  my $IRC_ALIAS = "log";  my $IRC_ALIAS = "log";
52    
53  my %FOLLOWS =  # default log to follow and announce messages
54    (  my $follows_path = 'follows.log';
    ACCESS => "/var/log/apache/access.log",  
    ERROR => "/var/log/apache/error.log",  
   );  
55    
56  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
57    
# Line 58  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S'; Line 60  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
60    
61  my $sleep_on_error = 5;  my $sleep_on_error = 5;
62    
63  ## END CONFIG  # number of last tags to keep in circular buffer
64    my $last_x_tags = 50;
65    
66    # don't pull rss feeds more often than this
67    my $rss_min_delay = 60;
68    $rss_min_delay = 15;
69    
70    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
71    
72    my $url = "http://$HOSTNAME:$http_port";
73    
74    ## END CONFIG
75    
76  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
77  use HTTP::Status;  use HTTP::Status;
# Line 73  use POSIX qw/strftime/; Line 84  use POSIX qw/strftime/;
84  use HTML::CalendarMonthSimple;  use HTML::CalendarMonthSimple;
85  use Getopt::Long;  use Getopt::Long;
86  use DateTime;  use DateTime;
87    use URI::Escape;
88  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
89  use Net::Twitter;  use DateTime::Format::ISO8601;
90    use Carp qw/confess/;
91    use XML::Feed;
92    use DateTime::Format::Flexible;
93    
94    my $use_twitter = 1;
95    eval { require Net::Twitter; };
96    $use_twitter = 0 if ($@);
97    
98  my $import_dircproxy;  my $import_dircproxy;
99  my $log_path;  my $log_path;
100  GetOptions(  GetOptions(
101          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
102            'follows:s' => \$follows_path,
103          'log:s' => \$log_path,          'log:s' => \$log_path,
104  );  );
105    
106    $SIG{__DIE__} = sub {
107            confess "fatal error";
108    };
109    
110  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
111    
112  sub _log {  sub _log {
113          print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;          print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;
114  }  }
115    
116    # LOG following
117    
118    my %FOLLOWS =
119      (
120    #   ACCESS => "/var/log/apache/access.log",
121    #   ERROR => "/var/log/apache/error.log",
122      );
123    
124    sub add_follow_path {
125            my $path = shift;
126            my $name = $path;
127            $name =~ s/\..*$//;
128            warn "# using $path to announce messages from $name\n";
129            $FOLLOWS{$name} = $path;
130    }
131    
132    add_follow_path( $follows_path ) if ( -e $follows_path );
133    
134    # HTML formatters
135    
136    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
137    my $escape_re  = join '|' => keys %escape;
138    
139    my $tag_regex = '\b([\w-_]+)//';
140    
141    my %nick_enumerator;
142    my $max_color = 0;
143    
144    my $filter = {
145            message => sub {
146                    my $m = shift || return;
147    
148                    # protect HTML from wiki modifications
149                    sub e {
150                            my $t = shift;
151                            return 'uri_unescape{' . uri_escape($t) . '}';
152                    }
153    
154                    $m =~ s/($escape_re)/$escape{$1}/gs;
155                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs ||
156                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
157                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
158                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
159                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
160    
161                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
162                    return $m;
163            },
164            nick => sub {
165                    my $n = shift || return;
166                    if (! $nick_enumerator{$n})  {
167                            my $max = scalar keys %nick_enumerator;
168                            $nick_enumerator{$n} = $max + 1;
169                    }
170                    return '<span class="nick col-' .
171                            ( $nick_enumerator{$n} % $max_color ) .
172                            '">' . $n . '</span>';
173            },
174    };
175    
176  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
177    
178  my $sql_schema = {  my $sql_schema = {
179          log => '          log => qq{
180  create table log (  create table log (
181          id serial,          id serial,
182          time timestamp default now(),          time timestamp default now(),
# Line 106  create table log ( Line 190  create table log (
190  create index log_time on log(time);  create index log_time on log(time);
191  create index log_channel on log(channel);  create index log_channel on log(channel);
192  create index log_nick on log(nick);  create index log_nick on log(nick);
193          ',          },
194          meta => '          meta => q{
195  create table meta (  create table meta (
196          nick text not null,          nick text not null,
197          channel text not null,          channel text not null,
198          name text not null,          name text not null,
199          value text,          value text,
200          changed timestamp default now(),          changed timestamp default 'now()',
201          primary key(nick,channel,name)          primary key(nick,channel,name)
202  );  );
203          ',          },
204            feeds => qq{
205    create table feeds (
206            id serial,
207            url text not null,
208            name text,
209            delay interval not null default '30 sec', --'5 min',
210            active boolean default true,
211            last_update timestamp default 'now()',
212            polls int default 0,
213            updates int default 0
214    );
215    create unique index feeds_url on feeds(url);
216    insert into feeds (url,name) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki');
217            },
218  };  };
219    
220  foreach my $table ( keys %$sql_schema ) {  foreach my $table ( keys %$sql_schema ) {
# Line 188  values (?,?,?,?,?) Line 286  values (?,?,?,?,?)
286    
287    
288  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
289    
290  =head2 get_from_log  =head2 get_from_log
291    
# Line 225  C<me>, C<nick> and C<message> keys. Line 322  C<me>, C<nick> and C<message> keys.
322  sub get_from_log {  sub get_from_log {
323          my $args = {@_};          my $args = {@_};
324    
325          $args->{fmt} ||= {          if ( ! $args->{fmt} ) {
326                  date => '[%s] ',                  $args->{fmt} = {
327                  time => '{%s} ',                          date => '[%s] ',
328                  time_channel => '{%s %s} ',                          time => '{%s} ',
329                  nick => '%s: ',                          time_channel => '{%s %s} ',
330                  me_nick => '***%s ',                          nick => '%s: ',
331                  message => '%s',                          me_nick => '***%s ',
332          };                          message => '%s',
333                    };
334            }
335    
336          my $sql_message = qq{          my $sql_message = qq{
337                  select                  select
# Line 255  sub get_from_log { Line 354  sub get_from_log {
354    
355          my $sql = $context ? $sql_context : $sql_message;          my $sql = $context ? $sql_context : $sql_message;
356    
357          $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});          sub check_date {
358          $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });                  my $date = shift || return;
359          $sql .= " where date(time) = ? " if ($args->{date});                  my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
360          $sql .= " order by log.time desc";                  if ( $@ ) {
361          $sql .= " limit " . $args->{limit} if ($args->{limit});                          warn "invalid date $date\n";
362                            $new_date = DateTime->now->ymd;
363                    }
364                    return $new_date;
365            }
366    
367            my @where;
368            my @args;
369    
         my $sth = $dbh->prepare( $sql );  
370          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
371                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
372                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
373                  $sth->execute( ( '%' . $search . '%' ) x 2 );                  push @where, 'message ilike ? or nick ilike ?';
374                  _log "search for '$search' returned ", $sth->rows, " results ", $context || '';                  push @args, ( ( '%' . $search . '%' ) x 2 );
375          } elsif (my $tag = $args->{tag}) {                  _log "search for '$search'";
376                  $sth->execute();          }
377                  _log "tag '$tag' returned ", $sth->rows, " results ", $context || '';  
378          } elsif (my $date = $args->{date}) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
379                  $sth->execute($date);                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
380                  _log "found ", $sth->rows, " messages for date $date ", $context || '';                  _log "search for tags $args->{tag}";
         } else {  
                 $sth->execute();  
381          }          }
382    
383            if (my $date = $args->{date} ) {
384                    $date = check_date( $date );
385                    push @where, 'date(time) = ?';
386                    push @args, $date;
387                    _log "search for date $date";
388            }
389    
390            $sql .= " where " . join(" and ", @where) if @where;
391    
392            $sql .= " order by log.time desc";
393            $sql .= " limit " . $args->{limit} if ($args->{limit});
394    
395            #warn "### sql: $sql ", dump( @args );
396    
397            my $sth = $dbh->prepare( $sql );
398            eval { $sth->execute( @args ) };
399            return if $@;
400    
401          my $last_row = {          my $last_row = {
402                  date => '',                  date => '',
403                  time => '',                  time => '',
# Line 396  my $cloud = HTML::TagCloud->new; Line 518  my $cloud = HTML::TagCloud->new;
518    
519  =head2 add_tag  =head2 add_tag
520    
521   add_tag( id => 42, message => 'irc message' );   add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
522    
523  =cut  =cut
524    
525    my @last_tags;
526    
527  sub add_tag {  sub add_tag {
528          my $arg = {@_};          my $arg = {@_};
529    
# Line 408  sub add_tag { Line 532  sub add_tag {
532          my $m = $arg->{message};          my $m = $arg->{message};
533          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
534    
535            my @tags;
536    
537          while ($m =~ s#$tag_regex##s) {          while ($m =~ s#$tag_regex##s) {
538                  my $tag = $1;                  my $tag = $1;
539                  next if (! $tag || $tag =~ m/https?:/i);                  next if (! $tag || $tag =~ m/https?:/i);
540                  push @{ $tags->{$tag} }, $arg->{id};                  push @{ $tags->{$tag} }, $arg->{id};
541                  #warn "+tag $tag: $arg->{id}\n";                  #warn "+tag $tag: $arg->{id}\n";
542                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
543                    push @tags, $tag;
544    
545            }
546    
547            if ( @tags ) {
548                    pop @last_tags if $#last_tags == $last_x_tags;
549                    unshift @last_tags, { tags => [ @tags ], %$arg };
550          }          }
551    
552  }  }
553    
554  =head2 seed_tags  =head2 seed_tags
# Line 424  Read all tags from database and create i Line 558  Read all tags from database and create i
558  =cut  =cut
559    
560  sub seed_tags {  sub seed_tags {
561          my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });          my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
562          $sth->execute;          $sth->execute;
563          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
564                  add_tag( %$row );                  add_tag( %$row );
565          }          }
566    
567          foreach my $tag (keys %$tags) {          foreach my $tag (keys %$tags) {
568                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
569          }          }
570  }  }
571    
# Line 444  seed_tags; Line 578  seed_tags;
578          channel => '#foobar',          channel => '#foobar',
579          me => 0,          me => 0,
580          nick => 'dpavlin',          nick => 'dpavlin',
581          msg => 'test message',          message => 'test message',
582          time => '2006-06-25 18:57:18',          time => '2006-06-25 18:57:18',
583    );    );
584    
# Line 456  C<me> if not specified will be C<0> (not Line 590  C<me> if not specified will be C<0> (not
590    
591  sub save_message {  sub save_message {
592          my $a = {@_};          my $a = {@_};
593            confess "have msg" if $a->{msg};
594          $a->{me} ||= 0;          $a->{me} ||= 0;
595          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
596    
597          _log          _log
598                  $a->{channel}, " ",                  $a->{channel}, " ",
599                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
600                  " " . $a->{msg};                  " " . $a->{message};
601    
602          from_to($a->{msg}, 'UTF-8', $ENCODING);          from_to($a->{message}, 'UTF-8', $ENCODING);
603    
604          $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});          $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
605          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
                 message => $a->{msg});  
606  }  }
607    
608    
609  if ($import_dircproxy) {  if ($import_dircproxy) {
610          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
611          warn "importing $import_dircproxy...\n";          warn "importing $import_dircproxy...\n";
612          my $tz_offset = 2 * 60 * 60;    # TZ GMT+2          my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
613          while(<$l>) {          while(<$l>) {
614                  chomp;                  chomp;
615                  if (/^@(\d+)\s(\S+)\s(.+)$/) {                  if (/^@(\d+)\s(\S+)\s(.+)$/) {
# Line 493  if ($import_dircproxy) { Line 627  if ($import_dircproxy) {
627                                  channel => $CHANNEL,                                  channel => $CHANNEL,
628                                  me => $me,                                  me => $me,
629                                  nick => $nick,                                  nick => $nick,
630                                  msg => $msg,                                  message => $msg,
631                                  time => $dt->ymd . " " . $dt->hms,                                  time => $dt->ymd . " " . $dt->hms,
632                          ) if ($nick !~ m/^-/);                          ) if ($nick !~ m/^-/);
633    
# Line 506  if ($import_dircproxy) { Line 640  if ($import_dircproxy) {
640          exit;          exit;
641  }  }
642    
643    #
644    # RSS follow
645    #
646    
647    my $_rss;
648    
649    
650    sub rss_fetch {
651            my ($args) = @_;
652    
653            # how many messages to send out when feed is seen for the first time?
654            my $send_rss_msgs = 1;
655    
656            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
657            if ( ! $feed ) {
658                    _log("can't fetch RSS ", $args->{url});
659                    return;
660            }
661            my $updates = 0;
662            for my $entry ($feed->entries) {
663    
664                    # seen allready?
665                    return if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;
666    
667                    sub prefix {
668                            my ($txt,$var) = @_;
669                            $var =~ s/^\s+//g;
670                            return $txt . $var if $var;
671                    }
672    
673                    my $msg;
674                    $msg .= prefix( 'From: ' , $feed->title );
675                    $msg .= prefix( ' by ' , $entry->author );
676                    $msg .= prefix( ' -- ' , $entry->link );
677    #               $msg .= prefix( ' id ' , $entry->id );
678    
679                    _log('RSS', $msg);
680    
681                    if ( $args->{kernel} && $send_rss_msgs ) {
682                            warn "# sending to $CHANNEL\n";
683                            $send_rss_msgs--;
684                            $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );
685                            $updates++;
686                    }
687            }
688    
689            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
690            $sql .= qq{, updates = updates + $updates } if $updates;
691            $sql .= qq{where id = } . $args->{id};
692            $dbh->do( $sql );
693    
694            return $updates;
695    }
696    
697    sub rss_fetch_all {
698            my $kernel = shift;
699            my $sql = qq{
700                    select id, url, name
701                    from feeds
702                    where active is true
703            };
704            # limit to newer feeds only if we are not sending messages out
705            $sql .= qq{     and last_update + delay < now() } if $kernel;
706            my $sth = $dbh->prepare( $sql );
707            $sth->execute();
708            warn "# ",$sth->rows," active RSS feeds\n";
709            my $count = 0;
710            while (my $row = $sth->fetchrow_hashref) {
711                    warn "+++ fetch RSS feed: ",dump( $row );
712                    $row->{kernel} = $kernel if $kernel;
713                    $count += rss_fetch( $row );
714            }
715            return "OK, fetched $count posts from " . $sth->rows . " feeds";
716    }
717    
718    my $rss_last_poll = time();
719    
720    sub rss_check_updates {
721            my $kernel = shift;
722            my $t = time();
723            if ( $rss_last_poll - $t > $rss_min_delay ) {
724                    $rss_last_poll = $t;
725                    _log rss_fetch_all( $kernel );
726            }
727    }
728    
729    # seed rss seen cache so we won't send out all items on startup
730    _log rss_fetch_all;
731    
732  #  #
733  # POE handing part  # POE handing part
# Line 517  my $ping;                                              # ping stats Line 739  my $ping;                                              # ping stats
739    
740  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
741    
742  POE::Session->create( inline_states =>  POE::Session->create( inline_states => {
743     {_start => sub {                _start => sub {      
744                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
745                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
746      },      },
# Line 526  POE::Session->create( inline_states => Line 748  POE::Session->create( inline_states =>
748                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
749                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
750                  $_[KERNEL]->yield("heartbeat"); # start heartbeat                  $_[KERNEL]->yield("heartbeat"); # start heartbeat
751  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;                  $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
752                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
753      },      },
754      irc_public => sub {      irc_public => sub {
# Line 535  POE::Session->create( inline_states => Line 757  POE::Session->create( inline_states =>
757                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
758                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
759    
760                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
761                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
762      },      },
763      irc_ctcp_action => sub {      irc_ctcp_action => sub {
# Line 544  POE::Session->create( inline_states => Line 766  POE::Session->create( inline_states =>
766                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
767                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
768    
769                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
770    
771                  if ( my $twitter = meta( $nick, $channel, 'twitter' ) ) {                  if ( $use_twitter ) {
772                          my ($login,$passwd) = split(/\s+/,$twitter,2);                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
773                          _log("sending twitter for $nick/$login on $channel ");                                  my ($login,$passwd) = split(/\s+/,$twitter,2);
774                          my $bot = Net::Twitter->new( username=>$login, password=>$passwd );                                  _log("sending twitter for $nick/$login on $channel ");
775                          $bot->update("<${channel}> $msg");                                  my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
776                                    $bot->update("<${channel}> $msg");
777                            }
778                  }                  }
779    
780      },      },
781          irc_ping => sub {          irc_ping => sub {
782                  warn "pong ", $_[ARG0], $/;                  _log( "pong ", $_[ARG0] );
783                  $ping->{ $_[ARG0] }++;                  $ping->{ $_[ARG0] }++;
784                    rss_check_updates( $_[KERNEL] );
785          },          },
786          irc_invite => sub {          irc_invite => sub {
787                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
788                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
789                  my $channel = $_[ARG1];                  my $channel = $_[ARG1];
790    
791                  warn "invited to $channel by $nick";                  _log "invited to $channel by $nick";
792    
793                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
794                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);
# Line 597  POE::Session->create( inline_states => Line 822  POE::Session->create( inline_states =>
822    
823                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
824                                  select                                  select
825                                          nick,                                          trim(both '_' from nick) as nick,
826                                          count(*) as count,                                          count(*) as count,
827                                          sum(length(message)) as len                                          sum(length(message)) as len
828                                  from log                                  from log
829                                  group by nick                                  group by trim(both '_' from nick)
830                                  order by len desc,count desc                                  order by len desc,count desc
831                                  limit $nr                                  limit $nr
832                          });                          });
# Line 703  POE::Session->create( inline_states => Line 928  POE::Session->create( inline_states =>
928                                          $res = "config option $op doesn't exist";                                          $res = "config option $op doesn't exist";
929                                  }                                  }
930                          }                          }
931                    } elsif ($msg =~ m/^rss-update/) {
932                            $res = rss_fetch_all( $_[KERNEL] );
933                    } elsif ($msg =~ m/^rss-clean/) {
934                            $_rss = undef;
935                            $res = "OK, cleaned RSS cache";
936                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {
937                            my $sql = {
938                                    add             => qq{ insert into feeds (url,name) values (?,?) },
939    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
940                                    start   => qq{ update feeds set active = true   where url = ? -- ? },
941                                    stop    => qq{ update feeds set active = false  where url = ? -- ? },
942                                    
943                            };
944                            if (my $q = $sql->{$1} ) {
945                                    my $sth = $dbh->prepare( $q );
946                                    warn "## SQL $q ( $2 | $3 )\n";
947                                    eval { $sth->execute( $2, $3 ) };
948                            }
949    
950                            $res ||= "OK, RSS $1 : $2 - $3";
951                  }                  }
952    
953                  if ($res) {                  if ($res) {
# Line 711  POE::Session->create( inline_states => Line 956  POE::Session->create( inline_states =>
956                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
957                  }                  }
958    
959                    rss_check_updates( $_[KERNEL] );
960          },          },
961          irc_477 => sub {          irc_477 => sub {
962                  _log "# irc_477: ",$_[ARG1];                  _log "# irc_477: ",$_[ARG1];
# Line 761  POE::Session->create( inline_states => Line 1007  POE::Session->create( inline_states =>
1007                       Filename => $FOLLOWS{$trailing},                       Filename => $FOLLOWS{$trailing},
1008                       InputEvent => 'got_line',                       InputEvent => 'got_line',
1009                      );                      );
1010                                    warn "+++ following $trailing at $FOLLOWS{$trailing}\n";
1011              },              },
1012              got_line => sub {              got_line => sub {
1013                $_[KERNEL]->post($session => my_tailed =>                                  warn "+++ $trailing : $_[ARG0]\n";
1014                                 time, $trailing, $_[ARG0]);                                  $_[KERNEL]->post($session => my_tailed => time, $trailing, $_[ARG0]);
1015              },              },
1016             },             },
1017            );            );
# Line 815  POE::Session->create( inline_states => Line 1062  POE::Session->create( inline_states =>
1062  # http server  # http server
1063    
1064  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1065          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1066            PreHandler => {
1067                    '/' => sub {
1068                            $_[0]->header(Connection => 'close')
1069                    }
1070            },
1071          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1072          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1073  );  );
1074    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1075  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1076  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1077  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 830  p { margin: 0; padding: 0.1em; } Line 1079  p { margin: 0; padding: 0.1em; }
1079  .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }  .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1080  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1081  .search { float: right; }  .search { float: right; }
1082    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1083    a:hover.tag { border: 1px solid #eee }
1084    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1085    /*
1086  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1087  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1088  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1089  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1090  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1091  a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }  */
1092  a:hover.tag { border: 1px solid #eee }  .calendar { border: 1px solid red; width: 100%; }
1093  hr { border: 1px dashed #ccc; height: 1px; clear: both; }  .month { border: 0px; width: 100%; }
1094  _END_OF_STYLE_  _END_OF_STYLE_
1095    
1096  my $max_color = 4;  $max_color = 0;
1097    
1098  my %nick_enumerator;  my @cols = qw(
1099            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1100            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1101            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1102            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1103            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1104    );
1105    
1106    foreach my $c (@cols) {
1107            $style .= ".col-${max_color} { background: $c }\n";
1108            $max_color++;
1109    }
1110    warn "defined $max_color colors for users...\n";
1111    
1112  sub root_handler {  sub root_handler {
1113          my ($request, $response) = @_;          my ($request, $response) = @_;
1114          $response->code(RC_OK);          $response->code(RC_OK);
1115          $response->content_type("text/html; charset=$ENCODING");  
1116            # this doesn't seem to work, so moved to PreHandler
1117            #$response->header(Connection => 'close');
1118    
1119            return RC_OK if $request->uri =~ m/favicon.ico$/;
1120    
1121          my $q;          my $q;
1122    
# Line 861  sub root_handler { Line 1130  sub root_handler {
1130    
1131          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1132    
1133            if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1134                    my $show = lc($1);
1135                    my $nr = $2;
1136    
1137                    my $type = 'RSS';       # Atom
1138    
1139                    $response->content_type( 'application/' . lc($type) . '+xml' );
1140    
1141                    my $html = '<!-- error -->';
1142                    #warn "create $type feed from ",dump( @last_tags );
1143    
1144                    my $feed = XML::Feed->new( $type );
1145                    $feed->link( $url );
1146    
1147                    if ( $show eq 'tags' ) {
1148                            $nr ||= 50;
1149                            $feed->title( "tags from $CHANNEL" );
1150                            $feed->link( "$url/tags" );
1151                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1152                            my $feed_entry = XML::Feed::Entry->new($type);
1153                            $feed_entry->title( "$nr tags from $CHANNEL" );
1154                            $feed_entry->author( $NICK );
1155                            $feed_entry->link( '/#tags'  );
1156    
1157                            $feed_entry->content(
1158                                    qq{<![CDATA[<style type="text/css">}
1159                                    . $cloud->css
1160                                    . qq{</style>}
1161                                    . $cloud->html( $nr )
1162                                    . qq{]]>}
1163                            );
1164                            $feed->add_entry( $feed_entry );
1165    
1166                    } elsif ( $show eq 'last-tag' ) {
1167    
1168                            $nr ||= $last_x_tags;
1169                            $nr = $last_x_tags if $nr > $last_x_tags;
1170    
1171                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1172                            $feed->description( "collects messages which have tags// in them" );
1173    
1174                            foreach my $m ( @last_tags ) {
1175    #                               warn dump( $m );
1176                                    #my $tags = join(' ', @{$m->{tags}} );
1177                                    my $feed_entry = XML::Feed::Entry->new($type);
1178                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1179                                    $feed_entry->author( $m->{nick} );
1180                                    $feed_entry->link( '/#' . $m->{id}  );
1181                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1182    
1183                                    my $message = $filter->{message}->( $m->{message} );
1184                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1185    #                               warn "## message = $message\n";
1186                                    from_to( $message, $ENCODING, 'UTF-8' );
1187    
1188                                    #$feed_entry->summary(
1189                                    $feed_entry->content(
1190                                            "<![CDATA[$message]]>"
1191                                    );
1192                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1193                                    $feed->add_entry( $feed_entry );
1194    
1195                                    $nr--;
1196                                    last if $nr <= 0;
1197    
1198                            }
1199    
1200                    } elsif ( $show =~ m/^follow/ ) {
1201    
1202                            $feed->title( "Feeds which this bot follows" );
1203    
1204                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1205                            $sth->execute;
1206                            while (my $row = $sth->fetchrow_hashref) {
1207                                    my $feed_entry = XML::Feed::Entry->new($type);
1208                                    $feed_entry->title( $row->{name} );
1209                                    $feed_entry->link( $row->{url}  );
1210                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1211                                    $feed_entry->content(
1212                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1213                                    );
1214                                    $feed->add_entry( $feed_entry );
1215                            }
1216    
1217                    } else {
1218                            _log "unknown rss request ",$request->url;
1219                            return RC_DENY;
1220                    }
1221    
1222                    $response->content( $feed->as_xml );
1223                    return RC_OK;
1224            }
1225    
1226            if ( $@ ) {
1227                    warn "$@";
1228            }
1229    
1230            $response->content_type("text/html; charset=$ENCODING");
1231    
1232          my $html =          my $html =
1233                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1234                  $cloud->css .                  . $cloud->css
1235                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1236                  qq{                  . qq{
1237                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1238                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1239                  <input type="submit" value="search">                  <input type="submit" value="search">
1240                  </form>                  </form>
1241                  } .                  }
1242                  $cloud->html(500) .                  . $cloud->html(500)
1243                  qq{<p>};                  . qq{<p>};
1244          if ($request->url =~ m#/history#) {  
1245            if ($request->url =~ m#/tags?#) {
1246                    # nop
1247            } elsif ($request->url =~ m#/history#) {
1248                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1249                          select date(time) as date,count(*) as nr                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1250                                  from log                                  from log
1251                                  group by date(time)                                  group by date(time)
1252                                  order by date(time) desc                                  order by date(time) desc
1253                  });                  });
1254                  $sth->execute();                  $sth->execute();
1255                  my ($l_yyyy,$l_mm) = (0,0);                  my ($l_yyyy,$l_mm) = (0,0);
1256                    $html .= qq{<table class="calendar"><tr>};
1257                  my $cal;                  my $cal;
1258                    my $ord = 0;
1259                  while (my $row = $sth->fetchrow_hashref) {                  while (my $row = $sth->fetchrow_hashref) {
1260                          # this is probably PostgreSQL specific, expects ISO date                          # this is probably PostgreSQL specific, expects ISO date
1261                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1262                          if ($yyyy != $l_yyyy || $mm != $l_mm) {                          if ($yyyy != $l_yyyy || $mm != $l_mm) {
1263                                  $html .= $cal->as_HTML() if ($cal);                                  if ( $cal ) {
1264                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1265                                            $ord++;
1266                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1267                                    }
1268                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1269                                  $cal->border(2);                                  $cal->border(1);
1270                                    $cal->width('30%');
1271                                    $cal->cellheight('5em');
1272                                    $cal->tableclass('month');
1273                                    #$cal->cellclass('day');
1274                                    $cal->sunday('SUN');
1275                                    $cal->saturday('SAT');
1276                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1277                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1278                          }                          }
1279                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1280                                  <a href="/?date=$row->{date}">$row->{nr}</a>                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1281                          });                          ]);
1282                            
1283                  }                  }
1284                  $html .= $cal->as_HTML() if ($cal);                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1285    
1286          } else {          } else {
1287                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1288                          get_from_log(                          get_from_log(
1289                                  limit => $q->param('last') || $q->param('date') ? undef : 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1290                                  search => $search || undef,                                  search => $search || undef,
1291                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1292                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
1293                                  fmt => {                                  fmt => {
1294                                          date => sub {                                          date => sub {
1295                                                  my $date = shift || return;                                                  my $date = shift || return;
1296                                                  qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div>};                                                  qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1297                                          },                                          },
1298                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1299                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 916  sub root_handler { Line 1301  sub root_handler {
1301                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1302                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1303                                  },                                  },
1304                                  filter => {                                  filter => $filter,
                                         message => sub {  
                                                 my $m = shift || return;  
                                                 $m =~ s/($escape_re)/$escape{$1}/gs;  
                                                 $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;  
                                                 $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;  
                                                 return $m;  
                                         },  
                                         nick => sub {  
                                                 my $n = shift || return;  
                                                 if (! $nick_enumerator{$n})  {  
                                                         my $max = scalar keys %nick_enumerator;  
                                                         $nick_enumerator{$n} = $max + 1;  
                                                 }  
                                                 return '<span class="nick col-' .  
                                                         ( $nick_enumerator{$n} % $max_color ) .  
                                                         '">' . $n . '</span>';  
                                         },  
                                 },  
1305                          )                          )
1306                  );                  );
1307          }          }
# Line 945  sub root_handler { Line 1312  sub root_handler {
1312          </body></html>};          </body></html>};
1313    
1314          $response->content( $html );          $response->content( $html );
1315            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1316          return RC_OK;          return RC_OK;
1317  }  }
1318    
Legend:
Removed from v.53  
changed lines
  Added in v.85
  ViewVC Help
Powered by ViewVC 1.1.26