/[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 69 by dpavlin, Fri Dec 7 12:51:55 2007 UTC revision 86 by dpavlin, Thu Mar 6 22:57:16 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    
58    # log output encoding
59  my $ENCODING = 'ISO-8859-2';  my $ENCODING = 'ISO-8859-2';
60  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
61    
62  my $sleep_on_error = 5;  my $sleep_on_error = 5;
63    
64  ## END CONFIG  # number of last tags to keep in circular buffer
65    my $last_x_tags = 50;
66    
67    # don't pull rss feeds more often than this
68    my $rss_min_delay = 60;
69    $rss_min_delay = 15;
70    
71    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
72    
73    my $url = "http://$HOSTNAME:$http_port";
74    
75    ## END CONFIG
76    
77  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
78  use HTTP::Status;  use HTTP::Status;
# Line 77  use URI::Escape; Line 89  use URI::Escape;
89  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
90  use DateTime::Format::ISO8601;  use DateTime::Format::ISO8601;
91  use Carp qw/confess/;  use Carp qw/confess/;
92    use XML::Feed;
93    use DateTime::Format::Flexible;
94    
95  my $use_twitter = 1;  my $use_twitter = 1;
96  eval { require Net::Twitter; };  eval { require Net::Twitter; };
# Line 86  my $import_dircproxy; Line 100  my $import_dircproxy;
100  my $log_path;  my $log_path;
101  GetOptions(  GetOptions(
102          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
103            'follows:s' => \$follows_path,
104          'log:s' => \$log_path,          'log:s' => \$log_path,
105  );  );
106    
# Line 96  $SIG{__DIE__} = sub { Line 111  $SIG{__DIE__} = sub {
111  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
112    
113  sub _log {  sub _log {
114          print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;          my $out = strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
115            from_to( $out, 'UTF-8', $ENCODING );
116            print $out;
117    }
118    
119    # LOG following
120    
121    my %FOLLOWS =
122      (
123    #   ACCESS => "/var/log/apache/access.log",
124    #   ERROR => "/var/log/apache/error.log",
125      );
126    
127    sub add_follow_path {
128            my $path = shift;
129            my $name = $path;
130            $name =~ s/\..*$//;
131            warn "# using $path to announce messages from $name\n";
132            $FOLLOWS{$name} = $path;
133  }  }
134    
135    add_follow_path( $follows_path ) if ( -e $follows_path );
136    
137    # HTML formatters
138    
139    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
140    my $escape_re  = join '|' => keys %escape;
141    
142    my $tag_regex = '\b([\w-_]+)//';
143    
144    my %nick_enumerator;
145    my $max_color = 0;
146    
147    my $filter = {
148            message => sub {
149                    my $m = shift || return;
150    
151                    # protect HTML from wiki modifications
152                    sub e {
153                            my $t = shift;
154                            return 'uri_unescape{' . uri_escape($t) . '}';
155                    }
156    
157                    $m =~ s/($escape_re)/$escape{$1}/gs;
158                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs ||
159                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
160                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
161                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
162                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
163    
164                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
165                    return $m;
166            },
167            nick => sub {
168                    my $n = shift || return;
169                    if (! $nick_enumerator{$n})  {
170                            my $max = scalar keys %nick_enumerator;
171                            $nick_enumerator{$n} = $max + 1;
172                    }
173                    return '<span class="nick col-' .
174                            ( $nick_enumerator{$n} % $max_color ) .
175                            '">' . $n . '</span>';
176            },
177    };
178    
179  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
180    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
181    
182  my $sql_schema = {  my $sql_schema = {
183          log => '          log => qq{
184  create table log (  create table log (
185          id serial,          id serial,
186          time timestamp default now(),          time timestamp default now(),
# Line 116  create table log ( Line 194  create table log (
194  create index log_time on log(time);  create index log_time on log(time);
195  create index log_channel on log(channel);  create index log_channel on log(channel);
196  create index log_nick on log(nick);  create index log_nick on log(nick);
197          ',          },
198          meta => '          meta => q{
199  create table meta (  create table meta (
200          nick text not null,          nick text not null,
201          channel text not null,          channel text not null,
202          name text not null,          name text not null,
203          value text,          value text,
204          changed timestamp default now(),          changed timestamp default 'now()',
205          primary key(nick,channel,name)          primary key(nick,channel,name)
206  );  );
207          ',          },
208            feeds => qq{
209    create table feeds (
210            id serial,
211            url text not null,
212            name text,
213            delay interval not null default '5 min',
214            active boolean default true,
215            last_update timestamp default 'now()',
216            polls int default 0,
217            updates int default 0
218    );
219    create unique index feeds_url on feeds(url);
220    insert into feeds (url,name) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki');
221            },
222  };  };
223    
224  foreach my $table ( keys %$sql_schema ) {  foreach my $table ( keys %$sql_schema ) {
# Line 198  values (?,?,?,?,?) Line 290  values (?,?,?,?,?)
290    
291    
292  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
293    
294  =head2 get_from_log  =head2 get_from_log
295    
# Line 431  my $cloud = HTML::TagCloud->new; Line 522  my $cloud = HTML::TagCloud->new;
522    
523  =head2 add_tag  =head2 add_tag
524    
525   add_tag( id => 42, message => 'irc message' );   add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
526    
527  =cut  =cut
528    
529    my @last_tags;
530    
531  sub add_tag {  sub add_tag {
532          my $arg = {@_};          my $arg = {@_};
533    
# Line 443  sub add_tag { Line 536  sub add_tag {
536          my $m = $arg->{message};          my $m = $arg->{message};
537          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
538    
539            my @tags;
540    
541          while ($m =~ s#$tag_regex##s) {          while ($m =~ s#$tag_regex##s) {
542                  my $tag = $1;                  my $tag = $1;
543                  next if (! $tag || $tag =~ m/https?:/i);                  next if (! $tag || $tag =~ m/https?:/i);
544                  push @{ $tags->{$tag} }, $arg->{id};                  push @{ $tags->{$tag} }, $arg->{id};
545                  #warn "+tag $tag: $arg->{id}\n";                  #warn "+tag $tag: $arg->{id}\n";
546                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
547                    push @tags, $tag;
548    
549          }          }
550    
551            if ( @tags ) {
552                    pop @last_tags if $#last_tags == $last_x_tags;
553                    unshift @last_tags, { tags => [ @tags ], %$arg };
554            }
555    
556  }  }
557    
558  =head2 seed_tags  =head2 seed_tags
# Line 459  Read all tags from database and create i Line 562  Read all tags from database and create i
562  =cut  =cut
563    
564  sub seed_tags {  sub seed_tags {
565          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 });
566          $sth->execute;          $sth->execute;
567          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
568                  add_tag( %$row );                  add_tag( %$row );
569          }          }
570    
571          foreach my $tag (keys %$tags) {          foreach my $tag (keys %$tags) {
572                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
573          }          }
574  }  }
575    
# Line 479  seed_tags; Line 582  seed_tags;
582          channel => '#foobar',          channel => '#foobar',
583          me => 0,          me => 0,
584          nick => 'dpavlin',          nick => 'dpavlin',
585          msg => 'test message',          message => 'test message',
586          time => '2006-06-25 18:57:18',          time => '2006-06-25 18:57:18',
587    );    );
588    
# Line 491  C<me> if not specified will be C<0> (not Line 594  C<me> if not specified will be C<0> (not
594    
595  sub save_message {  sub save_message {
596          my $a = {@_};          my $a = {@_};
597            confess "have msg" if $a->{msg};
598          $a->{me} ||= 0;          $a->{me} ||= 0;
599          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
600    
601          _log          _log
602                  $a->{channel}, " ",                  $a->{channel}, " ",
603                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
604                  " " . $a->{msg};                  " " . $a->{message};
605    
606          from_to($a->{msg}, 'UTF-8', $ENCODING);          $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
607            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
         $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});  
         add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),  
                 message => $a->{msg});  
608  }  }
609    
610    
# Line 528  if ($import_dircproxy) { Line 629  if ($import_dircproxy) {
629                                  channel => $CHANNEL,                                  channel => $CHANNEL,
630                                  me => $me,                                  me => $me,
631                                  nick => $nick,                                  nick => $nick,
632                                  msg => $msg,                                  message => $msg,
633                                  time => $dt->ymd . " " . $dt->hms,                                  time => $dt->ymd . " " . $dt->hms,
634                          ) if ($nick !~ m/^-/);                          ) if ($nick !~ m/^-/);
635    
# Line 541  if ($import_dircproxy) { Line 642  if ($import_dircproxy) {
642          exit;          exit;
643  }  }
644    
645    #
646    # RSS follow
647    #
648    
649    my $_rss;
650    
651    
652    sub rss_fetch {
653            my ($args) = @_;
654    
655            # how many messages to send out when feed is seen for the first time?
656            my $send_rss_msgs = 1;
657    
658            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
659            if ( ! $feed ) {
660                    _log("can't fetch RSS ", $args->{url});
661                    return;
662            }
663            my $updates = 0;
664            for my $entry ($feed->entries) {
665    
666                    # seen allready?
667                    return if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;
668    
669                    sub prefix {
670                            my ($txt,$var) = @_;
671                            $var =~ s/^\s+//g;
672                            return $txt . $var if $var;
673                    }
674    
675                    my $msg;
676                    $msg .= prefix( 'From: ' , $feed->title );
677                    $msg .= prefix( ' by ' , $entry->author );
678                    $msg .= prefix( ' -- ' , $entry->link );
679    #               $msg .= prefix( ' id ' , $entry->id );
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                            save_message( channel => $CHANNEL, me => 1, nick => $NICK, message => $msg );
687                            _log('RSS', $msg);
688                    }
689            }
690    
691            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
692            $sql .= qq{, updates = updates + $updates } if $updates;
693            $sql .= qq{where id = } . $args->{id};
694            eval { $dbh->do( $sql ) };
695    
696            return $updates;
697    }
698    
699    sub rss_fetch_all {
700            my $kernel = shift;
701            my $sql = qq{
702                    select id, url, name
703                    from feeds
704                    where active is true
705            };
706            # limit to newer feeds only if we are not sending messages out
707            $sql .= qq{     and last_update + delay < now() } if $kernel;
708            my $sth = $dbh->prepare( $sql );
709            $sth->execute();
710            warn "# ",$sth->rows," active RSS feeds\n";
711            my $count = 0;
712            while (my $row = $sth->fetchrow_hashref) {
713                    warn "+++ fetch RSS feed: ",dump( $row );
714                    $row->{kernel} = $kernel if $kernel;
715                    $count += rss_fetch( $row );
716            }
717            return "OK, fetched $count posts from " . $sth->rows . " feeds";
718    }
719    
720    my $rss_last_poll = time();
721    
722    sub rss_check_updates {
723            my $kernel = shift;
724            my $t = time();
725            if ( $rss_last_poll - $t > $rss_min_delay ) {
726                    $rss_last_poll = $t;
727                    _log rss_fetch_all( $kernel );
728            }
729    }
730    
731    # seed rss seen cache so we won't send out all items on startup
732    _log rss_fetch_all;
733    
734  #  #
735  # POE handing part  # POE handing part
# Line 552  my $ping;                                              # ping stats Line 741  my $ping;                                              # ping stats
741    
742  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
743    
744  POE::Session->create( inline_states =>  POE::Session->create( inline_states => {
745     {_start => sub {                _start => sub {      
746                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
747                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
748      },      },
# Line 561  POE::Session->create( inline_states => Line 750  POE::Session->create( inline_states =>
750                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
751                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
752                  $_[KERNEL]->yield("heartbeat"); # start heartbeat                  $_[KERNEL]->yield("heartbeat"); # start heartbeat
753  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;                  $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
754                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
755      },      },
756      irc_public => sub {      irc_public => sub {
# Line 570  POE::Session->create( inline_states => Line 759  POE::Session->create( inline_states =>
759                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
760                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
761    
762                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
763                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
764      },      },
765      irc_ctcp_action => sub {      irc_ctcp_action => sub {
# Line 579  POE::Session->create( inline_states => Line 768  POE::Session->create( inline_states =>
768                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
769                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
770    
771                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
772    
773                  if ( $use_twitter ) {                  if ( $use_twitter ) {
774                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
# Line 592  POE::Session->create( inline_states => Line 781  POE::Session->create( inline_states =>
781    
782      },      },
783          irc_ping => sub {          irc_ping => sub {
784                  warn "pong ", $_[ARG0], $/;                  _log( "pong ", $_[ARG0] );
785                  $ping->{ $_[ARG0] }++;                  $ping->{ $_[ARG0] }++;
786                    rss_check_updates( $_[KERNEL] );
787          },          },
788          irc_invite => sub {          irc_invite => sub {
789                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
790                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
791                  my $channel = $_[ARG1];                  my $channel = $_[ARG1];
792    
793                  warn "invited to $channel by $nick";                  _log "invited to $channel by $nick";
794    
795                  $_[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..." );
796                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);
# Line 611  POE::Session->create( inline_states => Line 801  POE::Session->create( inline_states =>
801                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
802                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
803                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
                 from_to($msg, 'UTF-8', $ENCODING);  
804    
805                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
806                  my @out;                  my @out;
# Line 655  POE::Session->create( inline_states => Line 844  POE::Session->create( inline_states =>
844    
845                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
846                                  _log "last: $res";                                  _log "last: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
847                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
848                          }                          }
849    
# Line 670  POE::Session->create( inline_states => Line 858  POE::Session->create( inline_states =>
858                                          search => $what,                                          search => $what,
859                                  )) {                                  )) {
860                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
                                 from_to($res, $ENCODING, 'UTF-8');  
861                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
862                          }                          }
863    
# Line 740  POE::Session->create( inline_states => Line 927  POE::Session->create( inline_states =>
927                                          $res = "config option $op doesn't exist";                                          $res = "config option $op doesn't exist";
928                                  }                                  }
929                          }                          }
930                    } elsif ($msg =~ m/^rss-update/) {
931                            $res = rss_fetch_all( $_[KERNEL] );
932                    } elsif ($msg =~ m/^rss-clean/) {
933                            $_rss = undef;
934                            $res = "OK, cleaned RSS cache";
935                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {
936                            my $sql = {
937                                    add             => qq{ insert into feeds (url,name) values (?,?) },
938    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
939                                    start   => qq{ update feeds set active = true   where url = ? -- ? },
940                                    stop    => qq{ update feeds set active = false  where url = ? -- ? },
941                                    
942                            };
943                            if (my $q = $sql->{$1} ) {
944                                    my $sth = $dbh->prepare( $q );
945                                    warn "## SQL $q ( $2 | $3 )\n";
946                                    eval { $sth->execute( $2, $3 ) };
947                            }
948    
949                            $res ||= "OK, RSS $1 : $2 - $3";
950                  }                  }
951    
952                  if ($res) {                  if ($res) {
953                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
                         from_to($res, $ENCODING, 'UTF-8');  
954                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
955                  }                  }
956    
957                    rss_check_updates( $_[KERNEL] );
958          },          },
959          irc_477 => sub {          irc_477 => sub {
960                  _log "# irc_477: ",$_[ARG1];                  _log "# irc_477: ",$_[ARG1];
# Line 798  POE::Session->create( inline_states => Line 1005  POE::Session->create( inline_states =>
1005                       Filename => $FOLLOWS{$trailing},                       Filename => $FOLLOWS{$trailing},
1006                       InputEvent => 'got_line',                       InputEvent => 'got_line',
1007                      );                      );
1008                                    warn "+++ following $trailing at $FOLLOWS{$trailing}\n";
1009              },              },
1010              got_line => sub {              got_line => sub {
1011                $_[KERNEL]->post($session => my_tailed =>                                  warn "+++ $trailing : $_[ARG0]\n";
1012                                 time, $trailing, $_[ARG0]);                                  $_[KERNEL]->post($session => my_tailed => time, $trailing, $_[ARG0]);
1013              },              },
1014             },             },
1015            );            );
# Line 852  POE::Session->create( inline_states => Line 1060  POE::Session->create( inline_states =>
1060  # http server  # http server
1061    
1062  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1063          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1064            PreHandler => {
1065                    '/' => sub {
1066                            $_[0]->header(Connection => 'close')
1067                    }
1068            },
1069          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1070          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1071  );  );
1072    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1073  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1074  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1075  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 881  hr { border: 1px dashed #ccc; height: 1p Line 1091  hr { border: 1px dashed #ccc; height: 1p
1091  .month { border: 0px; width: 100%; }  .month { border: 0px; width: 100%; }
1092  _END_OF_STYLE_  _END_OF_STYLE_
1093    
1094  my $max_color = 4;  $max_color = 0;
1095    
1096  my @cols = qw(  my @cols = qw(
1097          #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99          #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
# Line 891  my @cols = qw( Line 1101  my @cols = qw(
1101          #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff          #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1102  );  );
1103    
 $max_color = 0;  
1104  foreach my $c (@cols) {  foreach my $c (@cols) {
1105          $style .= ".col-${max_color} { background: $c }\n";          $style .= ".col-${max_color} { background: $c }\n";
1106          $max_color++;          $max_color++;
1107  }  }
1108  warn "defined $max_color colors for users...\n";  warn "defined $max_color colors for users...\n";
1109    
 my %nick_enumerator;  
   
1110  sub root_handler {  sub root_handler {
1111          my ($request, $response) = @_;          my ($request, $response) = @_;
1112          $response->code(RC_OK);          $response->code(RC_OK);
1113          $response->content_type("text/html; charset=$ENCODING");  
1114            # this doesn't seem to work, so moved to PreHandler
1115            #$response->header(Connection => 'close');
1116    
1117            return RC_OK if $request->uri =~ m/favicon.ico$/;
1118    
1119          my $q;          my $q;
1120    
# Line 917  sub root_handler { Line 1128  sub root_handler {
1128    
1129          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1130    
1131            if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1132                    my $show = lc($1);
1133                    my $nr = $2;
1134    
1135                    my $type = 'RSS';       # Atom
1136    
1137                    $response->content_type( 'application/' . lc($type) . '+xml' );
1138    
1139                    my $html = '<!-- error -->';
1140                    #warn "create $type feed from ",dump( @last_tags );
1141    
1142                    my $feed = XML::Feed->new( $type );
1143                    $feed->link( $url );
1144    
1145                    if ( $show eq 'tags' ) {
1146                            $nr ||= 50;
1147                            $feed->title( "tags from $CHANNEL" );
1148                            $feed->link( "$url/tags" );
1149                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1150                            my $feed_entry = XML::Feed::Entry->new($type);
1151                            $feed_entry->title( "$nr tags from $CHANNEL" );
1152                            $feed_entry->author( $NICK );
1153                            $feed_entry->link( '/#tags'  );
1154    
1155                            $feed_entry->content(
1156                                    qq{<![CDATA[<style type="text/css">}
1157                                    . $cloud->css
1158                                    . qq{</style>}
1159                                    . $cloud->html( $nr )
1160                                    . qq{]]>}
1161                            );
1162                            $feed->add_entry( $feed_entry );
1163    
1164                    } elsif ( $show eq 'last-tag' ) {
1165    
1166                            $nr ||= $last_x_tags;
1167                            $nr = $last_x_tags if $nr > $last_x_tags;
1168    
1169                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1170                            $feed->description( "collects messages which have tags// in them" );
1171    
1172                            foreach my $m ( @last_tags ) {
1173    #                               warn dump( $m );
1174                                    #my $tags = join(' ', @{$m->{tags}} );
1175                                    my $feed_entry = XML::Feed::Entry->new($type);
1176                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1177                                    $feed_entry->author( $m->{nick} );
1178                                    $feed_entry->link( '/#' . $m->{id}  );
1179                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1180    
1181                                    my $message = $filter->{message}->( $m->{message} );
1182                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1183    #                               warn "## message = $message\n";
1184    
1185                                    #$feed_entry->summary(
1186                                    $feed_entry->content(
1187                                            "<![CDATA[$message]]>"
1188                                    );
1189                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1190                                    $feed->add_entry( $feed_entry );
1191    
1192                                    $nr--;
1193                                    last if $nr <= 0;
1194    
1195                            }
1196    
1197                    } elsif ( $show =~ m/^follow/ ) {
1198    
1199                            $feed->title( "Feeds which this bot follows" );
1200    
1201                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1202                            $sth->execute;
1203                            while (my $row = $sth->fetchrow_hashref) {
1204                                    my $feed_entry = XML::Feed::Entry->new($type);
1205                                    $feed_entry->title( $row->{name} );
1206                                    $feed_entry->link( $row->{url}  );
1207                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1208                                    $feed_entry->content(
1209                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1210                                    );
1211                                    $feed->add_entry( $feed_entry );
1212                            }
1213    
1214                    } else {
1215                            _log "unknown rss request ",$request->url;
1216                            return RC_DENY;
1217                    }
1218    
1219                    $response->content( $feed->as_xml );
1220                    return RC_OK;
1221            }
1222    
1223            if ( $@ ) {
1224                    warn "$@";
1225            }
1226    
1227            $response->content_type("text/html; charset=UTF-8");
1228    
1229          my $html =          my $html =
1230                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1231                  $cloud->css .                  . $cloud->css
1232                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1233                  qq{                  . qq{
1234                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1235                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1236                  <input type="submit" value="search">                  <input type="submit" value="search">
1237                  </form>                  </form>
1238                  } .                  }
1239                  $cloud->html(500) .                  . $cloud->html(500)
1240                  qq{<p>};                  . qq{<p>};
1241          if ($request->url =~ m#/history#) {  
1242            if ($request->url =~ m#/tags?#) {
1243                    # nop
1244            } elsif ($request->url =~ m#/history#) {
1245                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1246                          select date(time) as date,count(*) as nr,sum(length(message)) as len                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1247                                  from log                                  from log
# Line 961  sub root_handler { Line 1273  sub root_handler {
1273                                  $cal->weekdays('MON','TUE','WED','THU','FRI');                                  $cal->weekdays('MON','TUE','WED','THU','FRI');
1274                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1275                          }                          }
1276                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1277                                  <a href="/?date=$row->{date}">$row->{nr}</a><br/>$row->{len}                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1278                          });                          ]);
1279                                                    
1280                  }                  }
1281                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
# Line 978  sub root_handler { Line 1290  sub root_handler {
1290                                  fmt => {                                  fmt => {
1291                                          date => sub {                                          date => sub {
1292                                                  my $date = shift || return;                                                  my $date = shift || return;
1293                                                  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>};
1294                                          },                                          },
1295                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1296                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 986  sub root_handler { Line 1298  sub root_handler {
1298                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1299                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1300                                  },                                  },
1301                                  filter => {                                  filter => $filter,
                                         message => sub {  
                                                 my $m = shift || return;  
   
                                                 # protect HTML from wiki modifications  
                                                 sub e {  
                                                         my $t = shift;  
                                                         return 'uri_unescape{' . uri_escape($t) . '}';  
                                                 }  
   
                                                 $m =~ s/($escape_re)/$escape{$1}/gs;  
                                                 $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;  
                                                 $m =~ s#$tag_regex#e(qq{<a href="?tag=$1" class="tag">$1</a>})#egs;  
                                                 $m =~ s#\*(\w+)\*#<b>$1</b>#gs;  
                                                 $m =~ s#_(\w+)_#<u>$1</u>#gs;  
                                                 $m =~ s#\/(\w+)\/#<i>$1</i>#gs;  
   
                                                 $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;  
                                                 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>';  
                                         },  
                                 },  
1302                          )                          )
1303                  );                  );
1304          }          }
# Line 1027  sub root_handler { Line 1309  sub root_handler {
1309          </body></html>};          </body></html>};
1310    
1311          $response->content( $html );          $response->content( $html );
1312            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1313          return RC_OK;          return RC_OK;
1314  }  }
1315    
Legend:
Removed from v.69  
changed lines
  Added in v.86
  ViewVC Help
Powered by ViewVC 1.1.26