/[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 59 by dpavlin, Sat Apr 7 22:57:08 2007 UTC revision 119 by dpavlin, Fri Mar 14 00:17:49 2008 UTC
# Line 2  Line 2 
2  use strict;  use strict;
3  $|++;  $|++;
4    
5    use POE qw(Component::IRC Component::Server::HTTP);
6    use HTTP::Status;
7    use DBI;
8    use Regexp::Common qw /URI/;
9    use CGI::Simple;
10    use HTML::TagCloud;
11    use POSIX qw/strftime/;
12    use HTML::CalendarMonthSimple;
13    use Getopt::Long;
14    use DateTime;
15    use URI::Escape;
16    use Data::Dump qw/dump/;
17    use DateTime::Format::ISO8601;
18    use Carp qw/confess/;
19    use XML::Feed;
20    use DateTime::Format::Flexible;
21    use IPC::DirQueue;
22    use File::Slurp;
23    
24  =head1 NAME  =head1 NAME
25    
26  irc-logger.pl  irc-logger.pl
# Line 20  Import log from C<dircproxy> to C<irc-lo Line 39  Import log from C<dircproxy> to C<irc-lo
39    
40  =item --log=irc-logger.log  =item --log=irc-logger.log
41    
 Name of log file  
   
42  =back  =back
43    
44  =head1 DESCRIPTION  =head1 DESCRIPTION
# Line 32  log all conversation on irc channel Line 49  log all conversation on irc channel
49    
50  ## CONFIG  ## CONFIG
51    
52  my $HOSTNAME = `hostname`;  my $debug = 0;
53    
54    my $irc_config = {
55            nick => 'irc-logger',
56            server => 'irc.freenode.net',
57            port => 6667,
58            ircname => 'Anna the bot: try /msg irc-logger help',
59    };
60    
61    my $queue_dir = './queue';
62    
63    my $HOSTNAME = `hostname -f`;
64    chomp($HOSTNAME);
65    
66    
 my $NICK = 'irc-logger';  
 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  
 my $CONNECT =  
   {Server => 'irc.freenode.net',  
    Nick => $NICK,  
    Ircname => "try /msg $NICK help",  
   };  
67  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
 $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  
 my $IRC_ALIAS = "log";  
68    
69  my %FOLLOWS =  if ( $HOSTNAME =~ m/llin/ ) {
70    (          $irc_config->{nick} = 'irc-logger-llin';
71     ACCESS => "/var/log/apache/access.log",  #       $irc_config = {
72     ERROR => "/var/log/apache/error.log",  #               nick => 'irc-logger-llin',
73    );  #               server => 'localhost',
74    #               port => 6668,
75    #       };
76            $CHANNEL = '#irc-logger';
77    } elsif ( $HOSTNAME =~ m/lugarin/ ) {
78            $irc_config->{server} = 'irc.carnet.hr';
79            $CHANNEL = '#riss';
80    }
81    
82    my @channels = ( $CHANNEL );
83    
84    warn "# config = ", dump( $irc_config ), $/;
85    
86    my $NICK = $irc_config->{nick} or die "no nick?";
87    
88  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
89    
 my $ENCODING = 'ISO-8859-2';  
90  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
91    
92  my $sleep_on_error = 5;  my $sleep_on_error = 5;
93    
94  ## END CONFIG  # number of last tags to keep in circular buffer
95    my $last_x_tags = 50;
96    
97    # don't pull rss feeds more often than this
98    my $rss_min_delay = 60;
99    
100    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
101    
102  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  my $url = "http://$HOSTNAME:$http_port";
103  use HTTP::Status;  
104  use DBI;  ## END CONFIG
 use Encode qw/from_to is_utf8/;  
 use Regexp::Common qw /URI/;  
 use CGI::Simple;  
 use HTML::TagCloud;  
 use POSIX qw/strftime/;  
 use HTML::CalendarMonthSimple;  
 use Getopt::Long;  
 use DateTime;  
 use Data::Dump qw/dump/;  
105    
106  my $use_twitter = 1;  my $use_twitter = 1;
107  eval { require Net::Twitter; };  eval { require Net::Twitter; };
# Line 84  my $log_path; Line 112  my $log_path;
112  GetOptions(  GetOptions(
113          'import-dircproxy:s' => \$import_dircproxy,          'import-dircproxy:s' => \$import_dircproxy,
114          'log:s' => \$log_path,          'log:s' => \$log_path,
115            'queue:s' => \$queue_dir,
116  );  );
117    
118  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  #$SIG{__DIE__} = sub {
119    #       confess "fatal error";
120    #};
121    
122  sub _log {  sub _log {
123          print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
124  }  }
125    
126    open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
127    
128    # queue
129    
130    if ( ! -d $queue_dir ) {
131            warn "## creating queue directory $queue_dir";
132            mkdir $queue_dir or die "can't create queue directory $queue_dir: $!";
133    }
134    
135    my $dq = IPC::DirQueue->new({ dir => $queue_dir });
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, '^a-zA-Z0-9') . '}';
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    # POE IRC
180    my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
181            die "can't start ", dump( $irc_config ), ": $!";
182    
183    my $irc = $poe_irc->session_id();
184    _log "IRC session_id $irc";
185    
186  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
187    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
188    
189  my $sql_schema = {  my $sql_schema = {
190          log => '          log => qq{
191  create table log (  create table log (
192          id serial,          id serial,
193          time timestamp default now(),          time timestamp default now(),
# Line 109  create table log ( Line 201  create table log (
201  create index log_time on log(time);  create index log_time on log(time);
202  create index log_channel on log(channel);  create index log_channel on log(channel);
203  create index log_nick on log(nick);  create index log_nick on log(nick);
204          ',          },
205          meta => '          meta => q{
206  create table meta (  create table meta (
207          nick text not null,          nick text not null,
208          channel text not null,          channel text not null,
209          name text not null,          name text not null,
210          value text,          value text,
211          changed timestamp default now(),          changed timestamp default 'now()',
212          primary key(nick,channel,name)          primary key(nick,channel,name)
213  );  );
214          ',          },
215            feeds => qq{
216    create table feeds (
217            id serial,
218            url text not null,
219            name text,
220            delay interval not null default '5 min',
221            active boolean default true,
222            channel text not null,
223            nick text not null,
224            private boolean default false,
225            last_update timestamp default 'now()',
226            polls int default 0,
227            updates int default 0
228    );
229    create unique index feeds_url on feeds(url);
230    insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
231            },
232  };  };
233    
234  foreach my $table ( keys %$sql_schema ) {  foreach my $table ( keys %$sql_schema ) {
# Line 162  sub meta { Line 271  sub meta {
271                  if ( $@ || ! $sth->rows ) {                  if ( $@ || ! $sth->rows ) {
272                          $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()) });
273                          $sth->execute( $value, $nick, $channel, $name );                          $sth->execute( $value, $nick, $channel, $name );
274                          _log "created $nick/$channel/$name = $value";                          warn "## created $nick/$channel/$name = $value\n";
275                  } else {                  } else {
276                          _log "updated $nick/$channel/$name = $value ";                          warn "## updated $nick/$channel/$name = $value\n";
277                  }                  }
278    
279                  return $value;                  return $value;
# Line 174  sub meta { Line 283  sub meta {
283                  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 = ? });
284                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
285                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
286                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
287                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
288                  return $v;                  return $v;
289    
# Line 183  sub meta { Line 292  sub meta {
292    
293    
294    
295  my $sth = $dbh->prepare(qq{  my $sth_insert_log = $dbh->prepare(qq{
296  insert into log  insert into log
297          (channel, me, nick, message, time)          (channel, me, nick, message, time)
298  values (?,?,?,?,?)  values (?,?,?,?,?)
# Line 191  values (?,?,?,?,?) Line 300  values (?,?,?,?,?)
300    
301    
302  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
303    
304  =head2 get_from_log  =head2 get_from_log
305    
# Line 228  C<me>, C<nick> and C<message> keys. Line 336  C<me>, C<nick> and C<message> keys.
336  sub get_from_log {  sub get_from_log {
337          my $args = {@_};          my $args = {@_};
338    
339          $args->{fmt} ||= {          if ( ! $args->{fmt} ) {
340                  date => '[%s] ',                  $args->{fmt} = {
341                  time => '{%s} ',                          date => '[%s] ',
342                  time_channel => '{%s %s} ',                          time => '{%s} ',
343                  nick => '%s: ',                          time_channel => '{%s %s} ',
344                  me_nick => '***%s ',                          nick => '%s: ',
345                  message => '%s',                          me_nick => '***%s ',
346          };                          message => '%s',
347                    };
348            }
349    
350          my $sql_message = qq{          my $sql_message = qq{
351                  select                  select
# Line 258  sub get_from_log { Line 368  sub get_from_log {
368    
369          my $sql = $context ? $sql_context : $sql_message;          my $sql = $context ? $sql_context : $sql_message;
370    
371          $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});          sub check_date {
372          $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });                  my $date = shift || return;
373          $sql .= " where date(time) = ? " if ($args->{date});                  my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
374          $sql .= " order by log.time desc";                  if ( $@ ) {
375          $sql .= " limit " . $args->{limit} if ($args->{limit});                          warn "invalid date $date\n";
376                            $new_date = DateTime->now->ymd;
377                    }
378                    return $new_date;
379            }
380    
381            my @where;
382            my @args;
383            my $msg;
384    
         my $sth = $dbh->prepare( $sql );  
385          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
386                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
387                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
388                  $sth->execute( ( '%' . $search . '%' ) x 2 );                  push @where, 'message ilike ? or nick ilike ?';
389                  _log "search for '$search' returned ", $sth->rows, " results ", $context || '';                  push @args, ( ( '%' . $search . '%' ) x 2 );
390          } elsif (my $tag = $args->{tag}) {                  $msg = "Search for '$search'";
391                  $sth->execute();          }
392                  _log "tag '$tag' returned ", $sth->rows, " results ", $context || '';  
393          } elsif (my $date = $args->{date}) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
394                  $sth->execute($date);                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
395                  _log "found ", $sth->rows, " messages for date $date ", $context || '';                  $msg = "Search for tags $args->{tag}";
         } else {  
                 $sth->execute();  
396          }          }
397    
398            if (my $date = $args->{date} ) {
399                    $date = check_date( $date );
400                    push @where, 'date(time) = ?';
401                    push @args, $date;
402                    $msg = "search for date $date";
403            }
404    
405            $sql .= " where " . join(" and ", @where) if @where;
406    
407            $sql .= " order by log.time desc";
408            $sql .= " limit " . $args->{limit} if ($args->{limit});
409    
410            #warn "### sql: $sql ", dump( @args );
411    
412            my $sth = $dbh->prepare( $sql );
413            eval { $sth->execute( @args ) };
414            return if $@;
415    
416            my $nr_results = $sth->rows;
417    
418          my $last_row = {          my $last_row = {
419                  date => '',                  date => '',
420                  time => '',                  time => '',
# Line 299  sub get_from_log { Line 435  sub get_from_log {
435    
436          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
437    
438          my @msgs = (          $msg .= ' produced ' . (
439                  "Showing " . ($#rows + 1) . " messages..."                  $nr_results == 0 ? 'no results' :
440                    $nr_results == 0 ? 'one result' :
441                            $nr_results . ' results'
442          );          );
443    
444            my @msgs = ( $msg );
445    
446          if ($context) {          if ($context) {
447                  my @ids = @rows;                  my @ids = @rows;
448                  @rows = ();                  @rows = ();
# Line 359  sub get_from_log { Line 499  sub get_from_log {
499  #                       $row->{nick} = $nick;  #                       $row->{nick} = $nick;
500  #               }  #               }
501    
502                    $append = 0 if $row->{me};
503    
504                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
505                          # 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
506                          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 399  my $cloud = HTML::TagCloud->new; Line 541  my $cloud = HTML::TagCloud->new;
541    
542  =head2 add_tag  =head2 add_tag
543    
544   add_tag( id => 42, message => 'irc message' );   add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
545    
546  =cut  =cut
547    
548    my @last_tags;
549    
550  sub add_tag {  sub add_tag {
551          my $arg = {@_};          my $arg = {@_};
552    
553          return unless ($arg->{id} && $arg->{message});          return unless ($arg->{id} && $arg->{message});
554    
555          my $m = $arg->{message};          my $m = $arg->{message};
556          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
557            my @tags;
558    
559          while ($m =~ s#$tag_regex##s) {          while ($m =~ s#$tag_regex##s) {
560                  my $tag = $1;                  my $tag = $1;
561                  next if (! $tag || $tag =~ m/https?:/i);                  next if (! $tag || $tag =~ m/https?:/i);
562                  push @{ $tags->{$tag} }, $arg->{id};                  push @{ $tags->{$tag} }, $arg->{id};
563                  #warn "+tag $tag: $arg->{id}\n";                  #warn "+tag $tag: $arg->{id}\n";
564                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
565                    push @tags, $tag;
566    
567            }
568    
569            if ( @tags ) {
570                    pop @last_tags if $#last_tags == $last_x_tags;
571                    unshift @last_tags, { tags => [ @tags ], %$arg };
572          }          }
573    
574  }  }
575    
576  =head2 seed_tags  =head2 seed_tags
# Line 427  Read all tags from database and create i Line 580  Read all tags from database and create i
580  =cut  =cut
581    
582  sub seed_tags {  sub seed_tags {
583          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 });
584          $sth->execute;          $sth->execute;
585          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
586                  add_tag( %$row );                  add_tag( %$row );
587          }          }
588    
589          foreach my $tag (keys %$tags) {          foreach my $tag (keys %$tags) {
590                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
591          }          }
592  }  }
593    
# Line 447  seed_tags; Line 600  seed_tags;
600          channel => '#foobar',          channel => '#foobar',
601          me => 0,          me => 0,
602          nick => 'dpavlin',          nick => 'dpavlin',
603          msg => 'test message',          message => 'test message',
604          time => '2006-06-25 18:57:18',          time => '2006-06-25 18:57:18',
605    );    );
606    
# Line 459  C<me> if not specified will be C<0> (not Line 612  C<me> if not specified will be C<0> (not
612    
613  sub save_message {  sub save_message {
614          my $a = {@_};          my $a = {@_};
615            confess "have msg" if $a->{msg};
616          $a->{me} ||= 0;          $a->{me} ||= 0;
617          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
618    
619          _log          _log
620                  $a->{channel}, " ",                  $a->{channel}, " ",
621                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
622                  " " . $a->{msg};                  " " . $a->{message};
623    
624          from_to($a->{msg}, 'UTF-8', $ENCODING);          $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
625            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});  
626  }  }
627    
628    
629  if ($import_dircproxy) {  if ($import_dircproxy) {
630          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
631          warn "importing $import_dircproxy...\n";          warn "importing $import_dircproxy...\n";
632          my $tz_offset = 2 * 60 * 60;    # TZ GMT+2          my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
633          while(<$l>) {          while(<$l>) {
634                  chomp;                  chomp;
635                  if (/^@(\d+)\s(\S+)\s(.+)$/) {                  if (/^@(\d+)\s(\S+)\s(.+)$/) {
# Line 496  if ($import_dircproxy) { Line 647  if ($import_dircproxy) {
647                                  channel => $CHANNEL,                                  channel => $CHANNEL,
648                                  me => $me,                                  me => $me,
649                                  nick => $nick,                                  nick => $nick,
650                                  msg => $msg,                                  message => $msg,
651                                  time => $dt->ymd . " " . $dt->hms,                                  time => $dt->ymd . " " . $dt->hms,
652                          ) if ($nick !~ m/^-/);                          ) if ($nick !~ m/^-/);
653    
# Line 509  if ($import_dircproxy) { Line 660  if ($import_dircproxy) {
660          exit;          exit;
661  }  }
662    
   
663  #  #
664  # POE handing part  # RSS follow
665  #  #
666    
667  my $SKIPPING = 0;               # if skipping, how many we've done  my $_stat;
668  my $SEND_QUEUE;                 # cache  
669  my $ping;                                               # ping stats  
670    sub rss_fetch {
671  POE::Component::IRC->new($IRC_ALIAS);          my ($args) = @_;
672    
673  POE::Session->create( inline_states =>  
674     {_start => sub {                # how many messages to send out when feed is seen for the first time?
675                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');          my $send_rss_msgs = 1;
676                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);  
677            _log "RSS fetch", $args->{url};
678    
679            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
680            if ( ! $feed ) {
681                    _log("can't fetch RSS ", $args->{url});
682                    return;
683            }
684    
685            $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
686    
687            my ( $total, $updates ) = ( 0, 0 );
688            for my $entry ($feed->entries) {
689                    $total++;
690    
691                    # seen allready?
692                    next if $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++ > 0;
693    
694                    sub prefix {
695                            my ($txt,$var) = @_;
696                            $var =~ s/\s+/ /gs;
697                            $var =~ s/^\s+//g;
698                            $var =~ s/\s+$//g;
699                            return $txt . $var if $var;
700                    }
701    
702                    # fix absolute and relative links to feed entries
703                    my $link = $entry->link;
704                    if ( $link =~ m!^/! ) {
705                            my $host = $args->{url};
706                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
707                            $link = "$host/$link";
708                    } elsif ( $link !~ m!^http! ) {
709                            $link = $args->{url} . $link;
710                    }
711    
712                    my $msg;
713                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
714                    $msg .= prefix( ' by ' , $entry->author );
715                    $msg .= prefix( ' | ' , $entry->title );
716                    $msg .= prefix( ' | ' , $link );
717    #               $msg .= prefix( ' id ' , $entry->id );
718                    if ( my $tags = $entry->category ) {
719                            $tags =~ s!^\s+!!;
720                            $tags =~ s!\s*$! !;
721                            $tags =~ s!,?\s+!// !g;
722                            $msg .= prefix( ' ' , $tags );
723                    }
724    
725                    if ( $args->{kernel} && $send_rss_msgs ) {
726                            $send_rss_msgs--;
727                            if ( ! $args->{private} ) {
728                                    # FIXME bug! should be save_message
729                                    save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
730    #                               $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
731                            }
732                            my ( $type, $to ) = ( 'notice', $args->{channel} );
733                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
734    
735                            _log(">> $type $to", $msg);
736    #                       $args->{kernel}->post( $irc => $type => $to, $msg );
737                            # XXX enqueue message to send later
738                            sub enqueue_post {
739                                    my $post = dump( @_ );
740                                    warn "## queue_post $post\n" if $debug;
741                                    $dq->enqueue_string( $post );
742                            }
743                            enqueue_post( $type => $to => $msg );
744    
745                            $updates++;
746                    }
747            }
748    
749            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
750            $sql .= qq{, updates = updates + $updates } if $updates;
751            $sql .= qq{where id = } . $args->{id};
752            eval { $dbh->do( $sql ) };
753    
754            _log "RSS got $total items of which $updates new";
755    
756            return $updates;
757    }
758    
759    sub rss_fetch_all {
760            my $kernel = shift;
761            my $sql = qq{
762                    select id, url, name, channel, nick, private
763                    from feeds
764                    where active is true
765            };
766            # limit to newer feeds only if we are not sending messages out
767            $sql .= qq{     and last_update + delay < now() } if $kernel;
768            my $sth = $dbh->prepare( $sql );
769            $sth->execute();
770            warn "# ",$sth->rows," active RSS feeds\n";
771            my $count = 0;
772            while (my $row = $sth->fetchrow_hashref) {
773                    $row->{kernel} = $kernel if $kernel;
774                    $count += rss_fetch( $row );
775            }
776            return "OK, fetched $count posts from " . $sth->rows . " feeds";
777    }
778    
779    
780    sub rss_check_updates {
781            my $kernel = shift;
782            $_stat->{rss}->{last_poll} ||= time();
783            my $dt = time() - $_stat->{rss}->{last_poll};
784            if ( $dt > $rss_min_delay ) {
785                    warn "## rss_check_updates $dt > $rss_min_delay\n";
786                    $_stat->{rss}->{last_poll} = time();
787                    _log rss_fetch_all( $kernel );
788            }
789            # XXX send queue messages
790            while ( my $job = $dq->pickup_queued_job() ) {
791                    my $data = read_file( $job->get_data_path ) || die "can't load ", $job->get_data_path, ": $!";
792    #               $kernel->post( $irc => $type => $to, $msg );
793                    my @data = eval $data;
794                    _log ">> post from queue ", $irc, @data;
795                    $kernel->post( $irc => @data );
796                    $job->finish;
797                    warn "## done queued job: ",dump( @data ) if $debug;
798            }
799    }
800    
801    # seed rss seen cache so we won't send out all items on startup
802    _log rss_fetch_all if ! $debug;
803    
804    POE::Session->create( inline_states => {
805            _start => sub {      
806                    $_[KERNEL]->post( $irc => register => 'all' );
807                    $_[KERNEL]->post( $irc => connect => {} );
808      },      },
809            irc_001 => sub {
810                    my ($kernel,$sender) = @_[KERNEL,SENDER];
811                    my $poco_object = $sender->get_heap();
812                    _log "connected to",$poco_object->server_name();
813                    $kernel->post( $sender => join => $_ ) for @channels;
814                    undef;
815            },
816      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
817                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post( $irc => join => $CHANNEL);
                 $_[KERNEL]->post($IRC_ALIAS => join => '#logger');  
                 $_[KERNEL]->yield("heartbeat"); # start heartbeat  
 #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
818      },      },
819      irc_public => sub {      irc_public => sub {
820                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 538  POE::Session->create( inline_states => Line 822  POE::Session->create( inline_states =>
822                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
823                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
824    
825                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
826                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
827                    rss_check_updates( $kernel );
828      },      },
829      irc_ctcp_action => sub {      irc_ctcp_action => sub {
830                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 547  POE::Session->create( inline_states => Line 832  POE::Session->create( inline_states =>
832                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
833                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
834    
835                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
836    
837                  if ( $use_twitter ) {                  if ( $use_twitter ) {
838                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
# Line 560  POE::Session->create( inline_states => Line 845  POE::Session->create( inline_states =>
845    
846      },      },
847          irc_ping => sub {          irc_ping => sub {
848                  warn "pong ", $_[ARG0], $/;                  _log( "pong ", $_[ARG0] );
849                  $ping->{ $_[ARG0] }++;                  $_stat->{ping}->{ $_[ARG0] }++;
850                    rss_check_updates( $_[KERNEL] );
851          },          },
852          irc_invite => sub {          irc_invite => sub {
853                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
854                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
855                  my $channel = $_[ARG1];                  my $channel = $_[ARG1];
856    
857                  warn "invited to $channel by $nick";                  _log "invited to $channel by $nick";
858    
859                  $_[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..." );
860                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post( $irc => 'join' => $channel );
861    
862          },          },
863          irc_msg => sub {          irc_msg => sub {
# Line 579  POE::Session->create( inline_states => Line 865  POE::Session->create( inline_states =>
865                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
866                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
867                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
868                  from_to($msg, 'UTF-8', $ENCODING);                  warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
869    
870                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
871                  my @out;                  my @out;
# Line 590  POE::Session->create( inline_states => Line 876  POE::Session->create( inline_states =>
876    
877                          $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";
878    
879                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
880    
881                          _log ">> /msg $1 $2";                          _log ">> /$1 $2 $3";
882                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $irc => $1 => $2, $3 );
883                          $res = '';                          $res = '';
884    
885                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
# Line 623  POE::Session->create( inline_states => Line 909  POE::Session->create( inline_states =>
909    
910                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
911                                  _log "last: $res";                                  _log "last: $res";
912                                  from_to($res, $ENCODING, 'UTF-8');                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
913                          }                          }
914    
915                          $res = '';                          $res = '';
# Line 638  POE::Session->create( inline_states => Line 923  POE::Session->create( inline_states =>
923                                          search => $what,                                          search => $what,
924                                  )) {                                  )) {
925                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
926                                  from_to($res, $ENCODING, 'UTF-8');                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
927                          }                          }
928    
929                          $res = '';                          $res = '';
# Line 674  POE::Session->create( inline_states => Line 958  POE::Session->create( inline_states =>
958                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
959                                  " from " . ( join(", ", @nicks) || 'nobody' );                                  " from " . ( join(", ", @nicks) || 'nobody' );
960    
961                          $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );                          $_[KERNEL]->post( $irc => notice => $nick, $res );
962    
963                  } elsif ($msg =~ m/^ping/) {                  } elsif ($msg =~ m/^ping/) {
964                          $res = "ping = " . dump( $ping );                          $res = "ping = " . dump( $_stat->{ping} );
965                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
966                          if ( ! defined( $1 ) ) {                          if ( ! defined( $1 ) ) {
967                                  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 708  POE::Session->create( inline_states => Line 992  POE::Session->create( inline_states =>
992                                          $res = "config option $op doesn't exist";                                          $res = "config option $op doesn't exist";
993                                  }                                  }
994                          }                          }
995                    } elsif ($msg =~ m/^rss-update/) {
996                            $res = rss_fetch_all( $_[KERNEL] );
997                    } elsif ($msg =~ m/^rss-list/) {
998                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
999                            $sth->execute;
1000                            while (my @row = $sth->fetchrow_array) {
1001                                    $_[KERNEL]->post( $irc => privmsg => $nick, join(' | ',@row) );
1002                            }
1003                            $res = '';
1004                    } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
1005                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
1006    
1007                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
1008                            $channel = $nick if $sub eq 'private';
1009    
1010                            my $sql = {
1011                                    add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
1012    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
1013                                    start   => qq{ update feeds set active = true   where url = ? },
1014                                    stop    => qq{ update feeds set active = false  where url = ? },
1015                                    clean   => qq{ update feeds set last_update = now() - delay where url = ? },
1016                            };
1017    
1018                            if ( $command eq 'add' && ! $channel ) {
1019                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
1020                            } elsif (my $q = $sql->{$command} ) {
1021                                    my $sth = $dbh->prepare( $q );
1022                                    my @data = ( $url );
1023                                    if ( $command eq 'add' ) {
1024                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
1025                                    }
1026                                    warn "## $command SQL $q with ",dump( @data ),"\n";
1027                                    eval { $sth->execute( @data ) };
1028                                    if ($@) {
1029                                            $res = "ERROR: $@";
1030                                    } else {
1031                                            $res = "OK, RSS executed $command " . ( $sub ? "-$sub" : '' ) ."on $channel url $url";
1032                                            if ( $command eq 'clean' ) {
1033                                                    my $seen = $_stat->{rss}->{seen} || die "no seen?";
1034                                                    my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
1035                                                    foreach my $c ( keys %$seen ) {
1036                                                            my $c_hash = $seen->{$c} || die "no seen->{$c}";
1037                                                            die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
1038                                                            foreach my $link ( keys %$c_hash ) {
1039                                                                    next unless $link eq $want_link;
1040                                                                    _log "RSS removed seen $c $url $link";
1041                                                            }
1042                                                    }
1043                                            }
1044                                    }
1045                            } else {
1046                                    $res = "ERROR: don't know what to do with: $msg";
1047                            }
1048                    } elsif ($msg =~ m/^rss-clean/) {
1049                            # this makes sense because we didn't catch rss-clean http://... before!
1050                            $_stat->{rss} = undef;
1051                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
1052                            $res = "OK, cleaned RSS cache";
1053                  }                  }
1054    
1055                  if ($res) {                  if ($res) {
1056                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
1057                          from_to($res, $ENCODING, 'UTF-8');                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                         $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
1058                  }                  }
1059    
1060                    rss_check_updates( $_[KERNEL] );
1061            },
1062            irc_372 => sub {
1063                    _log "<< motd",$_[ARG0],$_[ARG1];
1064            },
1065            irc_375 => sub {
1066                    _log "<< motd", $_[ARG0], "start";
1067            },
1068            irc_376 => sub {
1069                    _log "<< motd", $_[ARG0], "end";
1070          },          },
1071    #       irc_433 => sub {
1072    #               print "# irc_433: ",$_[ARG1], "\n";
1073    #               warn "## indetify $NICK\n";
1074    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1075    #       },
1076    #       irc_451 # please register
1077          irc_477 => sub {          irc_477 => sub {
1078                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
1079                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> IDENTIFY $NICK";
1080                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1081          },          },
1082          irc_505 => sub {          irc_505 => sub {
1083                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
1084                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> register $NICK";
1085  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );                  $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1086  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1087    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1088    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1089          },          },
1090          irc_registered => sub {          irc_registered => sub {
1091                  _log "## registrated $NICK";                  _log "<< registered $NICK";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1092          },          },
1093          irc_disconnected => sub {          irc_disconnected => sub {
1094                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1095                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1096                    $_[KERNEL]->post( $irc => connect => {} );
1097          },          },
1098          irc_socketerr => sub {          irc_socketerr => sub {
1099                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1100                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1101                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
1102            },
1103            irc_notice => sub {
1104                    _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1105                    my $m = $_[ARG2];
1106                    if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1107                            _log ">> suggested to $1 $2";
1108                            $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1109                    } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1110                            _log ">> registreted, so IDENTIFY";
1111                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1112                    } else {
1113                            warn "## ignore $m\n" if $debug;
1114                    }
1115            },
1116            irc_snotice => sub {
1117                    _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1118                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1119                            warn ">> $1 | $2\n";
1120                            $_[KERNEL]->post( $irc => lc($1) => $2);
1121                    }
1122          },          },
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
1123      _child => sub {},      _child => sub {},
1124      _default => sub {      _default => sub {
1125                  _log sprintf "sID:%s %s %s",                  _log sprintf "sID:%s %s %s",
# Line 754  POE::Session->create( inline_states => Line 1129  POE::Session->create( inline_states =>
1129                          "";                          "";
1130        0;                        # false for signals        0;                        # false for signals
1131      },      },
     my_add => sub {  
       my $trailing = $_[ARG0];  
       my $session = $_[SESSION];  
       POE::Session->create  
           (inline_states =>  
            {_start => sub {  
               $_[HEAP]->{wheel} =  
                 POE::Wheel::FollowTail->new  
                     (  
                      Filename => $FOLLOWS{$trailing},  
                      InputEvent => 'got_line',  
                     );  
             },  
             got_line => sub {  
               $_[KERNEL]->post($session => my_tailed =>  
                                time, $trailing, $_[ARG0]);  
             },  
            },  
           );  
       
     },  
     my_tailed => sub {  
       my ($time, $file, $line) = @_[ARG0..ARG2];  
       ## $time will be undef on a probe, or a time value if a real line  
   
       ## PoCo::IRC has throttling built in, but no external visibility  
       ## so this is reaching "under the hood"  
       $SEND_QUEUE ||=  
         $_[KERNEL]->alias_resolve($IRC_ALIAS)->get_heap->{send_queue};  
   
       ## handle "no need to keep skipping" transition  
       if ($SKIPPING and @$SEND_QUEUE < 1) {  
         $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                          "[discarded $SKIPPING messages]");  
         $SKIPPING = 0;  
       }  
   
       ## handle potential message display  
       if ($time) {  
         if ($SKIPPING or @$SEND_QUEUE > 3) { # 3 msgs per 10 seconds  
           $SKIPPING++;  
         } else {  
           my @time = localtime $time;  
           $_[KERNEL]->post($IRC_ALIAS => privmsg => $CHANNEL =>  
                            sprintf "%02d:%02d:%02d: %s: %s",  
                            ($time[2] + 11) % 12 + 1, $time[1], $time[0],  
                            $file, $line);  
         }  
       }  
   
       ## handle re-probe/flush if skipping  
       if ($SKIPPING) {  
         $_[KERNEL]->delay($_[STATE] => 0.5); # $time will be undef  
       }  
   
     },  
     my_heartbeat => sub {  
       $_[KERNEL]->yield(my_tailed => time, "heartbeat", "beep");  
       $_[KERNEL]->delay($_[STATE] => 10);  
     }  
1132     },     },
1133    );    );
1134    
1135  # http server  # http server
1136    
1137    _log "WEB archive at $url";
1138    
1139  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1140          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1141            PreHandler => {
1142                    '/' => sub {
1143                            $_[0]->header(Connection => 'close')
1144                    }
1145            },
1146          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1147          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1148  );  );
1149    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1150  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1151  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1152  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 835  p { margin: 0; padding: 0.1em; } Line 1154  p { margin: 0; padding: 0.1em; }
1154  .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 ; }
1155  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1156  .search { float: right; }  .search { float: right; }
1157    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1158    a:hover.tag { border: 1px solid #eee }
1159    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1160    /*
1161  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1162  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1163  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1164  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1165  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1166  a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }  */
1167  a:hover.tag { border: 1px solid #eee }  .calendar { border: 1px solid red; width: 100%; }
1168  hr { border: 1px dashed #ccc; height: 1px; clear: both; }  .month { border: 0px; width: 100%; }
1169  _END_OF_STYLE_  _END_OF_STYLE_
1170    
1171  my $max_color = 4;  $max_color = 0;
1172    
1173  my %nick_enumerator;  my @cols = qw(
1174            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1175            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1176            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1177            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1178            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1179    );
1180    
1181    foreach my $c (@cols) {
1182            $style .= ".col-${max_color} { background: $c }\n";
1183            $max_color++;
1184    }
1185    _log "WEB defined $max_color colors for users...";
1186    
1187  sub root_handler {  sub root_handler {
1188          my ($request, $response) = @_;          my ($request, $response) = @_;
1189          $response->code(RC_OK);          $response->code(RC_OK);
1190          $response->content_type("text/html; charset=$ENCODING");  
1191            # this doesn't seem to work, so moved to PreHandler
1192            #$response->header(Connection => 'close');
1193    
1194            return RC_OK if $request->uri =~ m/favicon.ico$/;
1195    
1196          my $q;          my $q;
1197    
# Line 865  sub root_handler { Line 1204  sub root_handler {
1204          }          }
1205    
1206          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1207            my $r_url = $request->url;
1208    
1209            my @commands = qw( tags last-tag follow stat );
1210            my $commands_re = join('|',@commands);
1211    
1212            if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1213                    my $show = lc($1);
1214                    my $nr = $2;
1215    
1216                    my $type = 'RSS';       # Atom
1217    
1218                    $response->content_type( 'application/' . lc($type) . '+xml' );
1219    
1220                    my $html = '<!-- error -->';
1221                    #warn "create $type feed from ",dump( @last_tags );
1222    
1223                    my $feed = XML::Feed->new( $type );
1224                    $feed->link( $url );
1225    
1226                    my $rc = RC_OK;
1227    
1228                    if ( $show eq 'tags' ) {
1229                            $nr ||= 50;
1230                            $feed->title( "tags from $CHANNEL" );
1231                            $feed->link( "$url/tags" );
1232                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1233                            my $feed_entry = XML::Feed::Entry->new($type);
1234                            $feed_entry->title( "$nr tags from $CHANNEL" );
1235                            $feed_entry->author( $NICK );
1236                            $feed_entry->link( '/#tags'  );
1237    
1238                            $feed_entry->content(
1239                                    qq{<![CDATA[<style type="text/css">}
1240                                    . $cloud->css
1241                                    . qq{</style>}
1242                                    . $cloud->html( $nr )
1243                                    . qq{]]>}
1244                            );
1245                            $feed->add_entry( $feed_entry );
1246    
1247                    } elsif ( $show eq 'last-tag' ) {
1248    
1249                            $nr ||= $last_x_tags;
1250                            $nr = $last_x_tags if $nr > $last_x_tags;
1251    
1252                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1253                            $feed->description( "collects messages which have tags// in them" );
1254    
1255                            foreach my $m ( @last_tags ) {
1256    #                               warn dump( $m );
1257                                    #my $tags = join(' ', @{$m->{tags}} );
1258                                    my $feed_entry = XML::Feed::Entry->new($type);
1259                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1260                                    $feed_entry->author( $m->{nick} );
1261                                    $feed_entry->link( '/#' . $m->{id}  );
1262                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1263    
1264                                    my $message = $filter->{message}->( $m->{message} );
1265                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1266    #                               warn "## message = $message\n";
1267    
1268                                    #$feed_entry->summary(
1269                                    $feed_entry->content(
1270                                            "<![CDATA[$message]]>"
1271                                    );
1272                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1273                                    $feed->add_entry( $feed_entry );
1274    
1275                                    $nr--;
1276                                    last if $nr <= 0;
1277    
1278                            }
1279    
1280                    } elsif ( $show =~ m/^follow/ ) {
1281    
1282                            $feed->title( "Feeds which this bot follows" );
1283    
1284                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1285                            $sth->execute;
1286                            while (my $row = $sth->fetchrow_hashref) {
1287                                    my $feed_entry = XML::Feed::Entry->new($type);
1288                                    $feed_entry->title( $row->{name} );
1289                                    $feed_entry->link( $row->{url}  );
1290                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1291                                    $feed_entry->content(
1292                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1293                                    );
1294                                    $feed->add_entry( $feed_entry );
1295                            }
1296    
1297                    } elsif ( $show =~ m/^stat/ ) {
1298    
1299                            my $feed_entry = XML::Feed::Entry->new($type);
1300                            $feed_entry->title( "Internal stats" );
1301                            $feed_entry->content(
1302                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1303                            );
1304                            $feed->add_entry( $feed_entry );
1305    
1306                    } else {
1307                            _log "WEB unknown rss request $r_url";
1308                            $feed->title( "unknown $r_url" );
1309                            foreach my $c ( @commands ) {
1310                                    my $feed_entry = XML::Feed::Entry->new($type);
1311                                    $feed_entry->title( "rss/$c" );
1312                                    $feed_entry->link( "$url/rss/$c" );
1313                                    $feed->add_entry( $feed_entry );
1314                            }
1315                            $rc = RC_DENY;
1316                    }
1317    
1318                    $response->content( $feed->as_xml );
1319                    return $rc;
1320            }
1321    
1322            if ( $@ ) {
1323                    warn "$@";
1324            }
1325    
1326            $response->content_type("text/html; charset=UTF-8");
1327    
1328          my $html =          my $html =
1329                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1330                  $cloud->css .                  . $cloud->css
1331                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1332                  qq{                  . qq{
1333                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1334                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1335                  <input type="submit" value="search">                  <input type="submit" value="search">
1336                  </form>                  </form>
1337                  } .                  }
1338                  $cloud->html(500) .                  . $cloud->html(500)
1339                  qq{<p>};                  . qq{<p>};
1340          if ($request->url =~ m#/history#) {  
1341            if ($request->url =~ m#/tags?#) {
1342                    # nop
1343            } elsif ($request->url =~ m#/history#) {
1344                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1345                          select date(time) as date,count(*) as nr                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1346                                  from log                                  from log
1347                                  group by date(time)                                  group by date(time)
1348                                  order by date(time) desc                                  order by date(time) desc
1349                  });                  });
1350                  $sth->execute();                  $sth->execute();
1351                  my ($l_yyyy,$l_mm) = (0,0);                  my ($l_yyyy,$l_mm) = (0,0);
1352                    $html .= qq{<table class="calendar"><tr>};
1353                  my $cal;                  my $cal;
1354                    my $ord = 0;
1355                  while (my $row = $sth->fetchrow_hashref) {                  while (my $row = $sth->fetchrow_hashref) {
1356                          # this is probably PostgreSQL specific, expects ISO date                          # this is probably PostgreSQL specific, expects ISO date
1357                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1358                          if ($yyyy != $l_yyyy || $mm != $l_mm) {                          if ($yyyy != $l_yyyy || $mm != $l_mm) {
1359                                  $html .= $cal->as_HTML() if ($cal);                                  if ( $cal ) {
1360                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1361                                            $ord++;
1362                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1363                                    }
1364                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1365                                  $cal->border(2);                                  $cal->border(1);
1366                                    $cal->width('30%');
1367                                    $cal->cellheight('5em');
1368                                    $cal->tableclass('month');
1369                                    #$cal->cellclass('day');
1370                                    $cal->sunday('SUN');
1371                                    $cal->saturday('SAT');
1372                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1373                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1374                          }                          }
1375                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1376                                  <a href="/?date=$row->{date}">$row->{nr}</a>                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1377                          });                          ]) if $cal;
1378                            
1379                  }                  }
1380                  $html .= $cal->as_HTML() if ($cal);                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1381    
1382          } else {          } else {
1383                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1384                          get_from_log(                          get_from_log(
1385                                  limit => $q->param('last') || $q->param('date') ? undef : 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1386                                  search => $search || undef,                                  search => $search || undef,
1387                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1388                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
1389                                  fmt => {                                  fmt => {
1390                                          date => sub {                                          date => sub {
1391                                                  my $date = shift || return;                                                  my $date = shift || return;
1392                                                  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>};
1393                                          },                                          },
1394                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1395                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 921  sub root_handler { Line 1397  sub root_handler {
1397                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1398                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1399                                  },                                  },
1400                                  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;  
                                                 $m =~ s#\*(\w+)\*#<b>$1</b>#gs;  
                                                 $m =~ s#_(\w+)_#<u>$1</u>#gs;  
                                                 $m =~ s#\/(\w+)\/#<i>$1</i>#gs;  
                                                 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>';  
                                         },  
                                 },  
1401                          )                          )
1402                  );                  );
1403          }          }
# Line 953  sub root_handler { Line 1408  sub root_handler {
1408          </body></html>};          </body></html>};
1409    
1410          $response->content( $html );          $response->content( $html );
1411            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1412          return RC_OK;          return RC_OK;
1413  }  }
1414    
Legend:
Removed from v.59  
changed lines
  Added in v.119
  ViewVC Help
Powered by ViewVC 1.1.26