/[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 50 by dpavlin, Sun Mar 18 15:37:05 2007 UTC revision 114 by dpavlin, Mon Mar 10 21:52: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    
22  =head1 NAME  =head1 NAME
23    
24  irc-logger.pl  irc-logger.pl
# Line 20  Import log from C<dircproxy> to C<irc-lo Line 37  Import log from C<dircproxy> to C<irc-lo
37    
38  =item --log=irc-logger.log  =item --log=irc-logger.log
39    
 Name of log file  
   
40  =back  =back
41    
42  =head1 DESCRIPTION  =head1 DESCRIPTION
# Line 32  log all conversation on irc channel Line 47  log all conversation on irc channel
47    
48  ## CONFIG  ## CONFIG
49    
50  my $HOSTNAME = `hostname`;  my $irc_config = {
51            nick => 'irc-logger',
52            server => 'irc.freenode.net',
53            port => 6667,
54            ircname => 'Anna the bot: try /msg irc-logger help',
55    };
56    
57    my $HOSTNAME = `hostname -f`;
58    chomp($HOSTNAME);
59    
60    
 my $NICK = 'irc-logger';  
 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);  
 my $CONNECT =  
   {Server => 'irc.freenode.net',  
    Nick => $NICK,  
    Ircname => "try /msg $NICK help",  
   };  
61  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
 $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);  
 my $IRC_ALIAS = "log";  
62    
63  my %FOLLOWS =  if ( $HOSTNAME =~ m/llin/ ) {
64    (          $irc_config->{nick} = 'irc-logger-llin';
65     ACCESS => "/var/log/apache/access.log",  #       $irc_config = {
66     ERROR => "/var/log/apache/error.log",  #               nick => 'irc-logger-llin',
67    );  #               server => 'localhost',
68    #               port => 6668,
69    #       };
70            $CHANNEL = '#irc-logger';
71    } elsif ( $HOSTNAME =~ m/lugarin/ ) {
72            $irc_config->{server} = 'irc.carnet.hr';
73            $CHANNEL = '#riss';
74    }
75    
76    my @channels = ( $CHANNEL );
77    
78    warn "# config = ", dump( $irc_config ), $/;
79    
80    my $NICK = $irc_config->{nick} or die "no nick?";
81    
82  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
83    
 my $ENCODING = 'ISO-8859-2';  
84  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
85    
86  my $sleep_on_error = 5;  my $sleep_on_error = 5;
87    
88  ## END CONFIG  # number of last tags to keep in circular buffer
89    my $last_x_tags = 50;
90    
91    # don't pull rss feeds more often than this
92    my $rss_min_delay = 60;
93    
94    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
95    
96  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  my $url = "http://$HOSTNAME:$http_port";
97  use HTTP::Status;  
98  use DBI;  ## END CONFIG
99  use Encode qw/from_to is_utf8/;  
100  use Regexp::Common qw /URI/;  my $use_twitter = 1;
101  use CGI::Simple;  eval { require Net::Twitter; };
102  use HTML::TagCloud;  $use_twitter = 0 if ($@);
 use POSIX qw/strftime/;  
 use HTML::CalendarMonthSimple;  
 use Getopt::Long;  
 use DateTime;  
 use Data::Dump qw/dump/;  
103    
104  my $import_dircproxy;  my $import_dircproxy;
105  my $log_path;  my $log_path;
# Line 82  GetOptions( Line 108  GetOptions(
108          'log:s' => \$log_path,          'log:s' => \$log_path,
109  );  );
110    
111    #$SIG{__DIE__} = sub {
112    #       confess "fatal error";
113    #};
114    
115  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
116    
117  sub _log {  sub _log {
118          print strftime($TIMESTAMP,localtime()), ' ', join(" ",@_), $/;          print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
119  }  }
120    
121    # HTML formatters
122    
123    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
124    my $escape_re  = join '|' => keys %escape;
125    
126    my $tag_regex = '\b([\w-_]+)//';
127    
128    my %nick_enumerator;
129    my $max_color = 0;
130    
131    my $filter = {
132            message => sub {
133                    my $m = shift || return;
134    
135                    # protect HTML from wiki modifications
136                    sub e {
137                            my $t = shift;
138                            return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
139                    }
140    
141                    $m =~ s/($escape_re)/$escape{$1}/gs;
142                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
143                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
144                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
145                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
146                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
147    
148                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
149                    return $m;
150            },
151            nick => sub {
152                    my $n = shift || return;
153                    if (! $nick_enumerator{$n})  {
154                            my $max = scalar keys %nick_enumerator;
155                            $nick_enumerator{$n} = $max + 1;
156                    }
157                    return '<span class="nick col-' .
158                            ( $nick_enumerator{$n} % $max_color ) .
159                            '">' . $n . '</span>';
160            },
161    };
162    
163    # POE IRC
164    my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
165            die "can't start ", dump( $irc_config ), ": $!";
166    
167    my $irc = $poe_irc->session_id();
168    _log "IRC session_id $irc";
169    
170  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
171    $dbh->do( qq{ set client_encoding = 'UTF-8' } );
172    
173  my $sql_schema = {  my $sql_schema = {
174          log => '          log => qq{
175  create table log (  create table log (
176          id serial,          id serial,
177          time timestamp default now(),          time timestamp default now(),
# Line 105  create table log ( Line 185  create table log (
185  create index log_time on log(time);  create index log_time on log(time);
186  create index log_channel on log(channel);  create index log_channel on log(channel);
187  create index log_nick on log(nick);  create index log_nick on log(nick);
188          ',          },
189          meta => '          meta => q{
190  create table meta (  create table meta (
191          nick text not null,          nick text not null,
192          channel text not null,          channel text not null,
193          name text not null,          name text not null,
194          value text,          value text,
195          changed timestamp default now(),          changed timestamp default 'now()',
196          primary key(nick,channel,name)          primary key(nick,channel,name)
197  );  );
198          ',          },
199            feeds => qq{
200    create table feeds (
201            id serial,
202            url text not null,
203            name text,
204            delay interval not null default '5 min',
205            active boolean default true,
206            channel text not null,
207            nick text not null,
208            private boolean default false,
209            last_update timestamp default 'now()',
210            polls int default 0,
211            updates int default 0
212    );
213    create unique index feeds_url on feeds(url);
214    insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
215            },
216  };  };
217    
218  foreach my $table ( keys %$sql_schema ) {  foreach my $table ( keys %$sql_schema ) {
# Line 158  sub meta { Line 255  sub meta {
255                  if ( $@ || ! $sth->rows ) {                  if ( $@ || ! $sth->rows ) {
256                          $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()) });
257                          $sth->execute( $value, $nick, $channel, $name );                          $sth->execute( $value, $nick, $channel, $name );
258                          _log "created $nick/$channel/$name = $value";                          warn "## created $nick/$channel/$name = $value\n";
259                  } else {                  } else {
260                          _log "updated $nick/$channel/$name = $value ";                          warn "## updated $nick/$channel/$name = $value\n";
261                  }                  }
262    
263                  return $value;                  return $value;
# Line 170  sub meta { Line 267  sub meta {
267                  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 = ? });
268                  $sth->execute( $nick, $channel, $name );                  $sth->execute( $nick, $channel, $name );
269                  my ($v,$c) = $sth->fetchrow_array;                  my ($v,$c) = $sth->fetchrow_array;
270                  _log "fetched $nick/$channel/$name = $v [$c]";                  warn "## fetched $nick/$channel/$name = $v [$c]\n";
271                  return ($v,$c) if wantarray;                  return ($v,$c) if wantarray;
272                  return $v;                  return $v;
273    
# Line 179  sub meta { Line 276  sub meta {
276    
277    
278    
279  my $sth = $dbh->prepare(qq{  my $sth_insert_log = $dbh->prepare(qq{
280  insert into log  insert into log
281          (channel, me, nick, message, time)          (channel, me, nick, message, time)
282  values (?,?,?,?,?)  values (?,?,?,?,?)
# Line 187  values (?,?,?,?,?) Line 284  values (?,?,?,?,?)
284    
285    
286  my $tags;  my $tags;
 my $tag_regex = '\b([\w-_]+)//';  
287    
288  =head2 get_from_log  =head2 get_from_log
289    
# Line 224  C<me>, C<nick> and C<message> keys. Line 320  C<me>, C<nick> and C<message> keys.
320  sub get_from_log {  sub get_from_log {
321          my $args = {@_};          my $args = {@_};
322    
323          $args->{fmt} ||= {          if ( ! $args->{fmt} ) {
324                  date => '[%s] ',                  $args->{fmt} = {
325                  time => '{%s} ',                          date => '[%s] ',
326                  time_channel => '{%s %s} ',                          time => '{%s} ',
327                  nick => '%s: ',                          time_channel => '{%s %s} ',
328                  me_nick => '***%s ',                          nick => '%s: ',
329                  message => '%s',                          me_nick => '***%s ',
330          };                          message => '%s',
331                    };
332            }
333    
334          my $sql_message = qq{          my $sql_message = qq{
335                  select                  select
# Line 254  sub get_from_log { Line 352  sub get_from_log {
352    
353          my $sql = $context ? $sql_context : $sql_message;          my $sql = $context ? $sql_context : $sql_message;
354    
355          $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});          sub check_date {
356          $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });                  my $date = shift || return;
357          $sql .= " where date(time) = ? " if ($args->{date});                  my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
358          $sql .= " order by log.time desc";                  if ( $@ ) {
359          $sql .= " limit " . $args->{limit} if ($args->{limit});                          warn "invalid date $date\n";
360                            $new_date = DateTime->now->ymd;
361                    }
362                    return $new_date;
363            }
364    
365            my @where;
366            my @args;
367            my $msg;
368    
         my $sth = $dbh->prepare( $sql );  
369          if (my $search = $args->{search}) {          if (my $search = $args->{search}) {
370                  $search =~ s/^\s+//;                  $search =~ s/^\s+//;
371                  $search =~ s/\s+$//;                  $search =~ s/\s+$//;
372                  $sth->execute( ( '%' . $search . '%' ) x 2 );                  push @where, 'message ilike ? or nick ilike ?';
373                  _log "search for '$search' returned ", $sth->rows, " results ", $context || '';                  push @args, ( ( '%' . $search . '%' ) x 2 );
374          } elsif (my $tag = $args->{tag}) {                  $msg = "Search for '$search'";
375                  $sth->execute();          }
376                  _log "tag '$tag' returned ", $sth->rows, " results ", $context || '';  
377          } elsif (my $date = $args->{date}) {          if ($args->{tag} && $tags->{ $args->{tag} }) {
378                  $sth->execute($date);                  push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
379                  _log "found ", $sth->rows, " messages for date $date ", $context || '';                  $msg = "Search for tags $args->{tag}";
         } else {  
                 $sth->execute();  
380          }          }
381    
382            if (my $date = $args->{date} ) {
383                    $date = check_date( $date );
384                    push @where, 'date(time) = ?';
385                    push @args, $date;
386                    $msg = "search for date $date";
387            }
388    
389            $sql .= " where " . join(" and ", @where) if @where;
390    
391            $sql .= " order by log.time desc";
392            $sql .= " limit " . $args->{limit} if ($args->{limit});
393    
394            #warn "### sql: $sql ", dump( @args );
395    
396            my $sth = $dbh->prepare( $sql );
397            eval { $sth->execute( @args ) };
398            return if $@;
399    
400            my $nr_results = $sth->rows;
401    
402          my $last_row = {          my $last_row = {
403                  date => '',                  date => '',
404                  time => '',                  time => '',
# Line 295  sub get_from_log { Line 419  sub get_from_log {
419    
420          return @rows if ($args->{full_rows});          return @rows if ($args->{full_rows});
421    
422          my @msgs = (          $msg .= ' produced ' . (
423                  "Showing " . ($#rows + 1) . " messages..."                  $nr_results == 0 ? 'no results' :
424                    $nr_results == 0 ? 'one result' :
425                            $nr_results . ' results'
426          );          );
427    
428            my @msgs = ( $msg );
429    
430          if ($context) {          if ($context) {
431                  my @ids = @rows;                  my @ids = @rows;
432                  @rows = ();                  @rows = ();
# Line 355  sub get_from_log { Line 483  sub get_from_log {
483  #                       $row->{nick} = $nick;  #                       $row->{nick} = $nick;
484  #               }  #               }
485    
486                    $append = 0 if $row->{me};
487    
488                  if ($last_row->{nick} ne $nick) {                  if ($last_row->{nick} ne $nick) {
489                          # 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
490                          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 395  my $cloud = HTML::TagCloud->new; Line 525  my $cloud = HTML::TagCloud->new;
525    
526  =head2 add_tag  =head2 add_tag
527    
528   add_tag( id => 42, message => 'irc message' );   add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
529    
530  =cut  =cut
531    
532    my @last_tags;
533    
534  sub add_tag {  sub add_tag {
535          my $arg = {@_};          my $arg = {@_};
536    
537          return unless ($arg->{id} && $arg->{message});          return unless ($arg->{id} && $arg->{message});
538    
539          my $m = $arg->{message};          my $m = $arg->{message};
540          from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));  
541            my @tags;
542    
543          while ($m =~ s#$tag_regex##s) {          while ($m =~ s#$tag_regex##s) {
544                  my $tag = $1;                  my $tag = $1;
545                  next if (! $tag || $tag =~ m/https?:/i);                  next if (! $tag || $tag =~ m/https?:/i);
546                  push @{ $tags->{$tag} }, $arg->{id};                  push @{ $tags->{$tag} }, $arg->{id};
547                  #warn "+tag $tag: $arg->{id}\n";                  #warn "+tag $tag: $arg->{id}\n";
548                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
549                    push @tags, $tag;
550    
551            }
552    
553            if ( @tags ) {
554                    pop @last_tags if $#last_tags == $last_x_tags;
555                    unshift @last_tags, { tags => [ @tags ], %$arg };
556          }          }
557    
558  }  }
559    
560  =head2 seed_tags  =head2 seed_tags
# Line 423  Read all tags from database and create i Line 564  Read all tags from database and create i
564  =cut  =cut
565    
566  sub seed_tags {  sub seed_tags {
567          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 });
568          $sth->execute;          $sth->execute;
569          while (my $row = $sth->fetchrow_hashref) {          while (my $row = $sth->fetchrow_hashref) {
570                  add_tag( %$row );                  add_tag( %$row );
571          }          }
572    
573          foreach my $tag (keys %$tags) {          foreach my $tag (keys %$tags) {
574                  $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);                  $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
575          }          }
576  }  }
577    
# Line 443  seed_tags; Line 584  seed_tags;
584          channel => '#foobar',          channel => '#foobar',
585          me => 0,          me => 0,
586          nick => 'dpavlin',          nick => 'dpavlin',
587          msg => 'test message',          message => 'test message',
588          time => '2006-06-25 18:57:18',          time => '2006-06-25 18:57:18',
589    );    );
590    
# Line 455  C<me> if not specified will be C<0> (not Line 596  C<me> if not specified will be C<0> (not
596    
597  sub save_message {  sub save_message {
598          my $a = {@_};          my $a = {@_};
599            confess "have msg" if $a->{msg};
600          $a->{me} ||= 0;          $a->{me} ||= 0;
601          $a->{time} ||= strftime($TIMESTAMP,localtime());          $a->{time} ||= strftime($TIMESTAMP,localtime());
602    
603          _log          _log
604                  $a->{channel}, " ",                  $a->{channel}, " ",
605                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",                  $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
606                  " " . $a->{msg};                  " " . $a->{message};
   
         from_to($a->{msg}, 'UTF-8', $ENCODING);  
607    
608          $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});          $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
609          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),          add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
                 message => $a->{msg});  
610  }  }
611    
612    
613  if ($import_dircproxy) {  if ($import_dircproxy) {
614          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";          open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
615          warn "importing $import_dircproxy...\n";          warn "importing $import_dircproxy...\n";
616          my $tz_offset = 2 * 60 * 60;    # TZ GMT+2          my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
617          while(<$l>) {          while(<$l>) {
618                  chomp;                  chomp;
619                  if (/^@(\d+)\s(\S+)\s(.+)$/) {                  if (/^@(\d+)\s(\S+)\s(.+)$/) {
# Line 492  if ($import_dircproxy) { Line 631  if ($import_dircproxy) {
631                                  channel => $CHANNEL,                                  channel => $CHANNEL,
632                                  me => $me,                                  me => $me,
633                                  nick => $nick,                                  nick => $nick,
634                                  msg => $msg,                                  message => $msg,
635                                  time => $dt->ymd . " " . $dt->hms,                                  time => $dt->ymd . " " . $dt->hms,
636                          ) if ($nick !~ m/^-/);                          ) if ($nick !~ m/^-/);
637    
# Line 505  if ($import_dircproxy) { Line 644  if ($import_dircproxy) {
644          exit;          exit;
645  }  }
646    
   
647  #  #
648  # POE handing part  # RSS follow
649  #  #
650    
651  my $SKIPPING = 0;               # if skipping, how many we've done  my $_stat;
652  my $SEND_QUEUE;                 # cache  
653  my $ping;                                               # ping stats  
654    sub rss_fetch {
655  POE::Component::IRC->new($IRC_ALIAS);          my ($args) = @_;
656    
657  POE::Session->create( inline_states =>          # how many messages to send out when feed is seen for the first time?
658     {_start => sub {                my $send_rss_msgs = 1;
659                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');  
660                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);          _log "RSS fetch", $args->{url};
661    
662            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
663            if ( ! $feed ) {
664                    _log("can't fetch RSS ", $args->{url});
665                    return;
666            }
667    
668            my ( $total, $updates ) = ( 0, 0 );
669            for my $entry ($feed->entries) {
670                    $total++;
671    
672                    # seen allready?
673                    next if $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++ > 0;
674    
675                    sub prefix {
676                            my ($txt,$var) = @_;
677                            $var =~ s/\s+/ /gs;
678                            $var =~ s/^\s+//g;
679                            $var =~ s/\s+$//g;
680                            return $txt . $var if $var;
681                    }
682    
683                    # fix absolute and relative links to feed entries
684                    my $link = $entry->link;
685                    if ( $link =~ m!^/! ) {
686                            my $host = $args->{url};
687                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
688                            $link = "$host/$link";
689                    } elsif ( $link !~ m!^http! ) {
690                            $link = $args->{url} . $link;
691                    }
692    
693                    my $msg;
694                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
695                    $msg .= prefix( ' by ' , $entry->author );
696                    $msg .= prefix( ' | ' , $entry->title );
697                    $msg .= prefix( ' | ' , $link );
698    #               $msg .= prefix( ' id ' , $entry->id );
699                    if ( my $tags = $entry->category ) {
700                            $tags =~ s!^\s+!!;
701                            $tags =~ s!\s*$! !;
702                            $tags =~ s!\s+!// !g;
703                            $msg .= prefix( ' ' , $tags );
704                    }
705    
706                    if ( $args->{kernel} && $send_rss_msgs ) {
707                            $send_rss_msgs--;
708                            if ( ! $args->{private} ) {
709                                    # FIXME bug! should be save_message
710    #                               save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
711                                    $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
712                            }
713                            my ( $type, $to ) = ( 'notice', $args->{channel} );
714                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
715                            _log(">> $type $to", $msg);
716                            $args->{kernel}->post( $irc => $type => $to, $msg );
717                            $updates++;
718                    }
719            }
720    
721            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
722            $sql .= qq{, updates = updates + $updates } if $updates;
723            $sql .= qq{where id = } . $args->{id};
724            eval { $dbh->do( $sql ) };
725    
726            _log "RSS got $total items of which $updates new";
727    
728            return $updates;
729    }
730    
731    sub rss_fetch_all {
732            my $kernel = shift;
733            my $sql = qq{
734                    select id, url, name, channel, nick, private
735                    from feeds
736                    where active is true
737            };
738            # limit to newer feeds only if we are not sending messages out
739            $sql .= qq{     and last_update + delay < now() } if $kernel;
740            my $sth = $dbh->prepare( $sql );
741            $sth->execute();
742            warn "# ",$sth->rows," active RSS feeds\n";
743            my $count = 0;
744            while (my $row = $sth->fetchrow_hashref) {
745                    $row->{kernel} = $kernel if $kernel;
746                    $count += rss_fetch( $row );
747            }
748            return "OK, fetched $count posts from " . $sth->rows . " feeds";
749    }
750    
751    
752    sub rss_check_updates {
753            my $kernel = shift;
754            $_stat->{rss}->{last_poll} ||= time();
755            my $dt = time() - $_stat->{rss}->{last_poll};
756            warn "## rss_check_updates $dt > $rss_min_delay\n";
757            if ( $dt > $rss_min_delay ) {
758                    $_stat->{rss}->{last_poll} = time();
759                    _log rss_fetch_all( $kernel );
760            }
761    }
762    
763    # seed rss seen cache so we won't send out all items on startup
764    _log rss_fetch_all;
765    
766    POE::Session->create( inline_states => {
767            _start => sub {      
768                    $_[KERNEL]->post( $irc => register => 'all' );
769                    $_[KERNEL]->post( $irc => connect => {} );
770      },      },
771            irc_001 => sub {
772                    my ($kernel,$sender) = @_[KERNEL,SENDER];
773                    my $poco_object = $sender->get_heap();
774                    _log "connected to",$poco_object->server_name();
775                    $kernel->post( $sender => join => $_ ) for @channels;
776                    undef;
777            },
778      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
779                  $_[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" );  
780      },      },
781      irc_public => sub {      irc_public => sub {
782                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 534  POE::Session->create( inline_states => Line 784  POE::Session->create( inline_states =>
784                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
785                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
786    
787                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
788                  meta( $nick, $channel, 'last-msg', $msg );                  meta( $nick, $channel, 'last-msg', $msg );
789                    rss_check_updates( $kernel );
790      },      },
791      irc_ctcp_action => sub {      irc_ctcp_action => sub {
792                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 543  POE::Session->create( inline_states => Line 794  POE::Session->create( inline_states =>
794                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
795                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
796    
797                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
798    
799                  if ( my $twitter = ( $nick, $channel, 'twitter' ) ) {                  if ( $use_twitter ) {
800                          _log("FIXME: send twitter for $nick on $channel [$twitter]");                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
801                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
802                                    _log("sending twitter for $nick/$login on $channel ");
803                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
804                                    $bot->update("<${channel}> $msg");
805                            }
806                  }                  }
807    
808      },      },
809          irc_ping => sub {          irc_ping => sub {
810                  warn "pong ", $_[ARG0], $/;                  _log( "pong ", $_[ARG0] );
811                  $ping->{ $_[ARG0] }++;                  $_stat->{ping}->{ $_[ARG0] }++;
812                    rss_check_updates( $_[KERNEL] );
813          },          },
814          irc_invite => sub {          irc_invite => sub {
815                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
816                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
817                  my $channel = $_[ARG1];                  my $channel = $_[ARG1];
818    
819                  warn "invited to $channel by $nick";                  _log "invited to $channel by $nick";
820    
821                  $_[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..." );
822                  $_[KERNEL]->post($IRC_ALIAS => join => $channel);                  $_[KERNEL]->post( $irc => 'join' => $channel );
823    
824          },          },
825          irc_msg => sub {          irc_msg => sub {
# Line 570  POE::Session->create( inline_states => Line 827  POE::Session->create( inline_states =>
827                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
828                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
829                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
                 from_to($msg, 'UTF-8', $ENCODING);  
830    
831                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
832                  my @out;                  my @out;
# Line 581  POE::Session->create( inline_states => Line 837  POE::Session->create( inline_states =>
837    
838                          $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";
839    
840                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
841    
842                          _log ">> /msg $1 $2";                          _log ">> /$1 $2 $3";
843                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $irc => $1 => $2, $3 );
844                          $res = '';                          $res = '';
845    
846                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
# Line 593  POE::Session->create( inline_states => Line 849  POE::Session->create( inline_states =>
849    
850                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
851                                  select                                  select
852                                          nick,                                          trim(both '_' from nick) as nick,
853                                          count(*) as count,                                          count(*) as count,
854                                          sum(length(message)) as len                                          sum(length(message)) as len
855                                  from log                                  from log
856                                  group by nick                                  group by trim(both '_' from nick)
857                                  order by len desc,count desc                                  order by len desc,count desc
858                                  limit $nr                                  limit $nr
859                          });                          });
# Line 614  POE::Session->create( inline_states => Line 870  POE::Session->create( inline_states =>
870    
871                          foreach my $res (get_from_log( limit => $limit )) {                          foreach my $res (get_from_log( limit => $limit )) {
872                                  _log "last: $res";                                  _log "last: $res";
873                                  from_to($res, $ENCODING, 'UTF-8');                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
874                          }                          }
875    
876                          $res = '';                          $res = '';
# Line 629  POE::Session->create( inline_states => Line 884  POE::Session->create( inline_states =>
884                                          search => $what,                                          search => $what,
885                                  )) {                                  )) {
886                                  _log "search [$what]: $res";                                  _log "search [$what]: $res";
887                                  from_to($res, $ENCODING, 'UTF-8');                                  $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
888                          }                          }
889    
890                          $res = '';                          $res = '';
# Line 665  POE::Session->create( inline_states => Line 919  POE::Session->create( inline_states =>
919                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .                                  " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
920                                  " from " . ( join(", ", @nicks) || 'nobody' );                                  " from " . ( join(", ", @nicks) || 'nobody' );
921    
922                          $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );                          $_[KERNEL]->post( $irc => notice => $nick, $res );
923    
924                  } elsif ($msg =~ m/^ping/) {                  } elsif ($msg =~ m/^ping/) {
925                          $res = "ping = " . dump( $ping );                          $res = "ping = " . dump( $_stat->{ping} );
926                  } elsif ($msg =~ m/^(?:twitter)\s+(\S+)\s+(.*?)/) {                  } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
                         if ( defined( $2 ) ) {  
                                 meta($nick, $channel, 'twitter', "$1\t$2");  
                                 $res = "saved twitter auth for $1 -- /me on $channel will auto-update twitter status";  
                         } else {  
                                 meta($nick, $channel, 'twitter', '' );  
                                 $res = "removed twitter status update for /me on $channel";  
                         }  
                 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size)*\s*(\d*)/) {  
927                          if ( ! defined( $1 ) ) {                          if ( ! defined( $1 ) ) {
928                                  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 = ? });
929                                  $sth->execute( $nick, $channel );                                  $sth->execute( $nick, $channel );
930                                  $res = "config for $nick ";                                  $res = "config for $nick on $channel";
931                                  while ( my ($n,$v) = $sth->fetchrow_array ) {                                  while ( my ($n,$v) = $sth->fetchrow_array ) {
932                                          $res .= "| $n = $v";                                          $res .= " | $n = $v";
933                                  }                                  }
934                          } elsif ( defined( $2 ) ) {                          } elsif ( ! $2 ) {
                                 meta( $nick, $channel, $1, $2 );  
                                 $res = "saved $1 = $2";  
                         } else {  
935                                  my $val = meta( $nick, $channel, $1 );                                  my $val = meta( $nick, $channel, $1 );
936                                  $res = "current $1 = " . ( $val ? $val : 'undefined' );                                  $res = "current $1 = " . ( $val ? $val : 'undefined' );
937                            } else {
938                                    my $validate = {
939                                            'last-size' => qr/^\d+/,
940                                            'twitter' => qr/^\w+\s+\w+/,
941                                    };
942    
943                                    my ( $op, $val ) = ( $1, $2 );
944    
945                                    if ( my $regex = $validate->{$op} ) {
946                                            if ( $val =~ $regex ) {
947                                                    meta( $nick, $channel, $op, $val );
948                                                    $res = "saved $op = $val";
949                                            } else {
950                                                    $res = "config option $op = $val doesn't validate against $regex";
951                                            }
952                                    } else {
953                                            $res = "config option $op doesn't exist";
954                                    }
955                            }
956                    } elsif ($msg =~ m/^rss-update/) {
957                            $res = rss_fetch_all( $_[KERNEL] );
958                    } elsif ($msg =~ m/^rss-clean/) {
959                            $_stat->{rss} = undef;
960                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
961                            $res = "OK, cleaned RSS cache";
962                    } elsif ($msg =~ m/^rss-list/) {
963                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
964                            $sth->execute;
965                            while (my @row = $sth->fetchrow_array) {
966                                    $_[KERNEL]->post( $irc => privmsg => $nick, join(' | ',@row) );
967                            }
968                            $res = '';
969                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
970                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
971    
972                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
973                            $channel = $nick if $sub eq 'private';
974    
975                            my $sql = {
976                                    add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
977    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
978                                    start   => qq{ update feeds set active = true   where url = ? },
979                                    stop    => qq{ update feeds set active = false  where url = ? },
980                            };
981    
982                            if ( $command eq 'add' && ! $channel ) {
983                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
984                            } elsif (my $q = $sql->{$command} ) {
985                                    my $sth = $dbh->prepare( $q );
986                                    my @data = ( $url );
987                                    if ( $command eq 'add' ) {
988                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
989                                    }
990                                    warn "## $command SQL $q with ",dump( @data ),"\n";
991                                    eval { $sth->execute( @data ) };
992                                    if ($@) {
993                                            $res = "ERROR: $@";
994                                    } else {
995                                            $res = "OK, RSS [$command|$sub|$url|$arg]";
996                                    }
997                            } else {
998                                    $res = "ERROR: don't know what to do with: $msg";
999                          }                          }
1000                  }                  }
1001    
1002                  if ($res) {                  if ($res) {
1003                          _log ">> [$nick] $res";                          _log ">> [$nick] $res";
1004                          from_to($res, $ENCODING, 'UTF-8');                          $_[KERNEL]->post( $irc => privmsg => $nick, $res );
                         $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );  
1005                  }                  }
1006    
1007                    rss_check_updates( $_[KERNEL] );
1008            },
1009            irc_372 => sub {
1010                    _log "<< motd",$_[ARG0],$_[ARG1];
1011            },
1012            irc_375 => sub {
1013                    _log "<< motd", $_[ARG0], "start";
1014          },          },
1015            irc_376 => sub {
1016                    _log "<< motd", $_[ARG0], "end";
1017            },
1018    #       irc_433 => sub {
1019    #               print "# irc_433: ",$_[ARG1], "\n";
1020    #               warn "## indetify $NICK\n";
1021    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1022    #       },
1023    #       irc_451 # please register
1024          irc_477 => sub {          irc_477 => sub {
1025                  _log "# irc_477: ",$_[ARG1];                  _log "<< irc_477: ",$_[ARG1];
1026                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> IDENTIFY $NICK";
1027                    $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1028          },          },
1029          irc_505 => sub {          irc_505 => sub {
1030                  _log "# irc_505: ",$_[ARG1];                  _log "<< irc_505: ",$_[ARG1];
1031                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  _log ">> register $NICK";
1032  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );                  $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1033  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1034    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1035    #               $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1036          },          },
1037          irc_registered => sub {          irc_registered => sub {
1038                  _log "## registrated $NICK";                  _log "<< registered $NICK";
                 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
1039          },          },
1040          irc_disconnected => sub {          irc_disconnected => sub {
1041                  _log "## disconnected, reconnecting again";                  _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1042                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  sleep($sleep_on_error);
1043                    $_[KERNEL]->post( $irc => connect => {} );
1044          },          },
1045          irc_socketerr => sub {          irc_socketerr => sub {
1046                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";                  _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1047                  sleep($sleep_on_error);                  sleep($sleep_on_error);
1048                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post( $irc => connect => {} );
1049            },
1050            irc_notice => sub {
1051                    _log "<< notice",$_[ARG0],dump($_[ARG1]);
1052                    if ( $_[ARG0] =~ m!/msg\s+NickServ\s+IDENTIFY!i ) {
1053                            _log ">> IDENTIFY";
1054                            $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1055                    }
1056            },
1057            irc_snotice => sub {
1058                    _log "<< snotice",$_[ARG0];
1059                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1060                            warn ">> $1 | $2\n";
1061                            $_[KERNEL]->post( $irc => lc($1) => $2);
1062                    }
1063          },          },
 #       irc_433 => sub {  
 #               print "# irc_433: ",$_[ARG1], "\n";  
 #               warn "## indetify $NICK\n";  
 #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  
 #       },  
1064      _child => sub {},      _child => sub {},
1065      _default => sub {      _default => sub {
1066                  _log sprintf "sID:%s %s %s",                  _log sprintf "sID:%s %s %s",
# Line 738  POE::Session->create( inline_states => Line 1070  POE::Session->create( inline_states =>
1070                          "";                          "";
1071        0;                        # false for signals        0;                        # false for signals
1072      },      },
     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);  
     }  
1073     },     },
1074    );    );
1075    
1076  # http server  # http server
1077    
1078    _log "WEB archive at $url";
1079    
1080  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1081          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1082            PreHandler => {
1083                    '/' => sub {
1084                            $_[0]->header(Connection => 'close')
1085                    }
1086            },
1087          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1088          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1089  );  );
1090    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1091  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1092  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1093  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
# Line 819  p { margin: 0; padding: 0.1em; } Line 1095  p { margin: 0; padding: 0.1em; }
1095  .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 ; }
1096  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1097  .search { float: right; }  .search { float: right; }
1098    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1099    a:hover.tag { border: 1px solid #eee }
1100    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1101    /*
1102  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1103  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1104  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1105  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1106  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1107  a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }  */
1108  a:hover.tag { border: 1px solid #eee }  .calendar { border: 1px solid red; width: 100%; }
1109  hr { border: 1px dashed #ccc; height: 1px; clear: both; }  .month { border: 0px; width: 100%; }
1110  _END_OF_STYLE_  _END_OF_STYLE_
1111    
1112  my $max_color = 4;  $max_color = 0;
1113    
1114  my %nick_enumerator;  my @cols = qw(
1115            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1116            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1117            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1118            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1119            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1120    );
1121    
1122    foreach my $c (@cols) {
1123            $style .= ".col-${max_color} { background: $c }\n";
1124            $max_color++;
1125    }
1126    _log "WEB defined $max_color colors for users...";
1127    
1128  sub root_handler {  sub root_handler {
1129          my ($request, $response) = @_;          my ($request, $response) = @_;
1130          $response->code(RC_OK);          $response->code(RC_OK);
1131          $response->content_type("text/html; charset=$ENCODING");  
1132            # this doesn't seem to work, so moved to PreHandler
1133            #$response->header(Connection => 'close');
1134    
1135            return RC_OK if $request->uri =~ m/favicon.ico$/;
1136    
1137          my $q;          my $q;
1138    
# Line 849  sub root_handler { Line 1145  sub root_handler {
1145          }          }
1146    
1147          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1148            my $r_url = $request->url;
1149    
1150            my @commands = qw( tags last-tag follow stat );
1151            my $commands_re = join('|',@commands);
1152    
1153            if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1154                    my $show = lc($1);
1155                    my $nr = $2;
1156    
1157                    my $type = 'RSS';       # Atom
1158    
1159                    $response->content_type( 'application/' . lc($type) . '+xml' );
1160    
1161                    my $html = '<!-- error -->';
1162                    #warn "create $type feed from ",dump( @last_tags );
1163    
1164                    my $feed = XML::Feed->new( $type );
1165                    $feed->link( $url );
1166    
1167                    my $rc = RC_OK;
1168    
1169                    if ( $show eq 'tags' ) {
1170                            $nr ||= 50;
1171                            $feed->title( "tags from $CHANNEL" );
1172                            $feed->link( "$url/tags" );
1173                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1174                            my $feed_entry = XML::Feed::Entry->new($type);
1175                            $feed_entry->title( "$nr tags from $CHANNEL" );
1176                            $feed_entry->author( $NICK );
1177                            $feed_entry->link( '/#tags'  );
1178    
1179                            $feed_entry->content(
1180                                    qq{<![CDATA[<style type="text/css">}
1181                                    . $cloud->css
1182                                    . qq{</style>}
1183                                    . $cloud->html( $nr )
1184                                    . qq{]]>}
1185                            );
1186                            $feed->add_entry( $feed_entry );
1187    
1188                    } elsif ( $show eq 'last-tag' ) {
1189    
1190                            $nr ||= $last_x_tags;
1191                            $nr = $last_x_tags if $nr > $last_x_tags;
1192    
1193                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1194                            $feed->description( "collects messages which have tags// in them" );
1195    
1196                            foreach my $m ( @last_tags ) {
1197    #                               warn dump( $m );
1198                                    #my $tags = join(' ', @{$m->{tags}} );
1199                                    my $feed_entry = XML::Feed::Entry->new($type);
1200                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1201                                    $feed_entry->author( $m->{nick} );
1202                                    $feed_entry->link( '/#' . $m->{id}  );
1203                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1204    
1205                                    my $message = $filter->{message}->( $m->{message} );
1206                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1207    #                               warn "## message = $message\n";
1208    
1209                                    #$feed_entry->summary(
1210                                    $feed_entry->content(
1211                                            "<![CDATA[$message]]>"
1212                                    );
1213                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1214                                    $feed->add_entry( $feed_entry );
1215    
1216                                    $nr--;
1217                                    last if $nr <= 0;
1218    
1219                            }
1220    
1221                    } elsif ( $show =~ m/^follow/ ) {
1222    
1223                            $feed->title( "Feeds which this bot follows" );
1224    
1225                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1226                            $sth->execute;
1227                            while (my $row = $sth->fetchrow_hashref) {
1228                                    my $feed_entry = XML::Feed::Entry->new($type);
1229                                    $feed_entry->title( $row->{name} );
1230                                    $feed_entry->link( $row->{url}  );
1231                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1232                                    $feed_entry->content(
1233                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1234                                    );
1235                                    $feed->add_entry( $feed_entry );
1236                            }
1237    
1238                    } elsif ( $show =~ m/^stat/ ) {
1239    
1240                            my $feed_entry = XML::Feed::Entry->new($type);
1241                            $feed_entry->title( "Internal stats" );
1242                            $feed_entry->content(
1243                                    '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1244                            );
1245                            $feed->add_entry( $feed_entry );
1246    
1247                    } else {
1248                            _log "WEB unknown rss request $r_url";
1249                            $feed->title( "unknown $r_url" );
1250                            foreach my $c ( @commands ) {
1251                                    my $feed_entry = XML::Feed::Entry->new($type);
1252                                    $feed_entry->title( "rss/$c" );
1253                                    $feed_entry->link( "$url/rss/$c" );
1254                                    $feed->add_entry( $feed_entry );
1255                            }
1256                            $rc = RC_DENY;
1257                    }
1258    
1259                    $response->content( $feed->as_xml );
1260                    return $rc;
1261            }
1262    
1263            if ( $@ ) {
1264                    warn "$@";
1265            }
1266    
1267            $response->content_type("text/html; charset=UTF-8");
1268    
1269          my $html =          my $html =
1270                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style}
1271                  $cloud->css .                  . $cloud->css
1272                  qq{</style></head><body>} .                  . qq{</style></head><body>}
1273                  qq{                  . qq{
1274                  <form method="post" class="search" action="/">                  <form method="post" class="search" action="/">
1275                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1276                  <input type="submit" value="search">                  <input type="submit" value="search">
1277                  </form>                  </form>
1278                  } .                  }
1279                  $cloud->html(500) .                  . $cloud->html(500)
1280                  qq{<p>};                  . qq{<p>};
1281          if ($request->url =~ m#/history#) {  
1282            if ($request->url =~ m#/tags?#) {
1283                    # nop
1284            } elsif ($request->url =~ m#/history#) {
1285                  my $sth = $dbh->prepare(qq{                  my $sth = $dbh->prepare(qq{
1286                          select date(time) as date,count(*) as nr                          select date(time) as date,count(*) as nr,sum(length(message)) as len
1287                                  from log                                  from log
1288                                  group by date(time)                                  group by date(time)
1289                                  order by date(time) desc                                  order by date(time) desc
1290                  });                  });
1291                  $sth->execute();                  $sth->execute();
1292                  my ($l_yyyy,$l_mm) = (0,0);                  my ($l_yyyy,$l_mm) = (0,0);
1293                    $html .= qq{<table class="calendar"><tr>};
1294                  my $cal;                  my $cal;
1295                    my $ord = 0;
1296                  while (my $row = $sth->fetchrow_hashref) {                  while (my $row = $sth->fetchrow_hashref) {
1297                          # this is probably PostgreSQL specific, expects ISO date                          # this is probably PostgreSQL specific, expects ISO date
1298                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});                          my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1299                          if ($yyyy != $l_yyyy || $mm != $l_mm) {                          if ($yyyy != $l_yyyy || $mm != $l_mm) {
1300                                  $html .= $cal->as_HTML() if ($cal);                                  if ( $cal ) {
1301                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1302                                            $ord++;
1303                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1304                                    }
1305                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);                                  $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1306                                  $cal->border(2);                                  $cal->border(1);
1307                                    $cal->width('30%');
1308                                    $cal->cellheight('5em');
1309                                    $cal->tableclass('month');
1310                                    #$cal->cellclass('day');
1311                                    $cal->sunday('SUN');
1312                                    $cal->saturday('SAT');
1313                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1314                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);                                  ($l_yyyy,$l_mm) = ($yyyy,$mm);
1315                          }                          }
1316                          $cal->setcontent($dd, qq{                          $cal->setcontent($dd, qq[
1317                                  <a href="/?date=$row->{date}">$row->{nr}</a>                                  <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1318                          });                          ]) if $cal;
1319                            
1320                  }                  }
1321                  $html .= $cal->as_HTML() if ($cal);                  $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1322    
1323          } else {          } else {
1324                  $html .= join("</p><p>",                  $html .= join("</p><p>",
1325                          get_from_log(                          get_from_log(
1326                                  limit => $q->param('last') || $q->param('date') ? undef : 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1327                                  search => $search || undef,                                  search => $search || undef,
1328                                  tag => $q->param('tag') || undef,                                  tag => $q->param('tag') || undef,
1329                                  date => $q->param('date') || undef,                                  date => $q->param('date') || undef,
1330                                  fmt => {                                  fmt => {
1331                                          date => sub {                                          date => sub {
1332                                                  my $date = shift || return;                                                  my $date = shift || return;
1333                                                  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>};
1334                                          },                                          },
1335                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1336                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
# Line 905  sub root_handler { Line 1338  sub root_handler {
1338                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1339                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1340                                  },                                  },
1341                                  filter => {                                  filter => $filter,
                                         message => sub {  
                                                 my $m = shift || return;  
                                                 $m =~ s/($escape_re)/$escape{$1}/gs;  
                                                 $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;  
                                                 $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;  
                                                 return $m;  
                                         },  
                                         nick => sub {  
                                                 my $n = shift || return;  
                                                 if (! $nick_enumerator{$n})  {  
                                                         my $max = scalar keys %nick_enumerator;  
                                                         $nick_enumerator{$n} = $max + 1;  
                                                 }  
                                                 return '<span class="nick col-' .  
                                                         ( $nick_enumerator{$n} % $max_color ) .  
                                                         '">' . $n . '</span>';  
                                         },  
                                 },  
1342                          )                          )
1343                  );                  );
1344          }          }
# Line 934  sub root_handler { Line 1349  sub root_handler {
1349          </body></html>};          </body></html>};
1350    
1351          $response->content( $html );          $response->content( $html );
1352            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1353          return RC_OK;          return RC_OK;
1354  }  }
1355    
Legend:
Removed from v.50  
changed lines
  Added in v.114
  ViewVC Help
Powered by ViewVC 1.1.26