/[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

trunk/irc-logger.pl revision 20 by dpavlin, Tue Mar 14 17:17:53 2006 UTC trunk/bin/irc-logger.pl revision 105 by dpavlin, Sun Mar 9 19:13:16 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 10  irc-logger.pl Line 27  irc-logger.pl
27    
28  ./irc-logger.pl  ./irc-logger.pl
29    
30    =head2 Options
31    
32    =over 4
33    
34    =item --import-dircproxy=filename
35    
36    Import log from C<dircproxy> to C<irc-logger> database
37    
38    =item --log=irc-logger.log
39    
40    =back
41    
42  =head1 DESCRIPTION  =head1 DESCRIPTION
43    
44  log all conversation on irc channel  log all conversation on irc channel
# Line 18  log all conversation on irc channel Line 47  log all conversation on irc channel
47    
48  ## CONFIG  ## CONFIG
49    
50    my $HOSTNAME = `hostname -f`;
51    chomp($HOSTNAME);
52    
53  my $NICK = 'irc-logger';  my $NICK = 'irc-logger';
54  my $CONNECT =  $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
55    {Server => 'irc.freenode.net',  my $CONNECT = {
56     Nick => $NICK,          Server => 'irc.freenode.net',
57     Ircname => "try /msg $NICK help",          Nick => $NICK,
58    };          Ircname => "try /msg $NICK help",
59    };
60  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
61    $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
62  my $IRC_ALIAS = "log";  my $IRC_ALIAS = "log";
63    
64  my %FOLLOWS =  if ( $HOSTNAME =~ m/lugarin/ ) {
65    (          $CONNECT->{Server} = 'irc.carnet.hr';
66     ACCESS => "/var/log/apache/access.log",          $CHANNEL = '#riss';
67     ERROR => "/var/log/apache/error.log",  }
68    );  
69    warn dump( $HOSTNAME, $CONNECT );
70    
71  my $DSN = 'DBI:Pg:dbname=' . $NICK;  my $DSN = 'DBI:Pg:dbname=' . $NICK;
72    
73  my $ENCODING = 'ISO-8859-2';  my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
74    
75    my $sleep_on_error = 5;
76    
77    # number of last tags to keep in circular buffer
78    my $last_x_tags = 50;
79    
80    # don't pull rss feeds more often than this
81    my $rss_min_delay = 60;
82    
83    my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
84    
85    my $url = "http://$HOSTNAME:$http_port";
86    
87  ## END CONFIG  ## END CONFIG
88    
89    my $use_twitter = 1;
90    eval { require Net::Twitter; };
91    $use_twitter = 0 if ($@);
92    
93    my $import_dircproxy;
94    my $log_path;
95    GetOptions(
96            'import-dircproxy:s' => \$import_dircproxy,
97            'log:s' => \$log_path,
98    );
99    
100    #$SIG{__DIE__} = sub {
101    #       confess "fatal error";
102    #};
103    
104  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
 use HTTP::Status;  
 use DBI;  
 use Encode qw/from_to/;  
 use Regexp::Common qw /URI/;  
 use CGI::Simple;  
105    
106    sub _log {
107            print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
108    }
109    
110  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  # HTML formatters
111    
112    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
113    my $escape_re  = join '|' => keys %escape;
114    
115    my $tag_regex = '\b([\w-_]+)//';
116    
117    my %nick_enumerator;
118    my $max_color = 0;
119    
120    my $filter = {
121            message => sub {
122                    my $m = shift || return;
123    
124                    # protect HTML from wiki modifications
125                    sub e {
126                            my $t = shift;
127                            return 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}';
128                    }
129    
130                    $m =~ s/($escape_re)/$escape{$1}/gs;
131                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
132                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
133                    $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
134                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
135                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
136    
137  eval {                  $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
138          $dbh->do(qq{ select count(*) from log });                  return $m;
139            },
140            nick => sub {
141                    my $n = shift || return;
142                    if (! $nick_enumerator{$n})  {
143                            my $max = scalar keys %nick_enumerator;
144                            $nick_enumerator{$n} = $max + 1;
145                    }
146                    return '<span class="nick col-' .
147                            ( $nick_enumerator{$n} % $max_color ) .
148                            '">' . $n . '</span>';
149            },
150  };  };
151    
152  if ($@) {  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
153          warn "creating database table in $DSN\n";  $dbh->do( qq{ set client_encoding = 'UTF-8' } );
         $dbh->do(<<'_SQL_SCHEMA_');  
154    
155    my $sql_schema = {
156            log => qq{
157  create table log (  create table log (
158          id serial,          id serial,
159          time timestamp default now(),          time timestamp default now(),
# Line 72  create table log ( Line 167  create table log (
167  create index log_time on log(time);  create index log_time on log(time);
168  create index log_channel on log(channel);  create index log_channel on log(channel);
169  create index log_nick on log(nick);  create index log_nick on log(nick);
170            },
171            meta => q{
172    create table meta (
173            nick text not null,
174            channel text not null,
175            name text not null,
176            value text,
177            changed timestamp default 'now()',
178            primary key(nick,channel,name)
179    );
180            },
181            feeds => qq{
182    create table feeds (
183            id serial,
184            url text not null,
185            name text,
186            delay interval not null default '5 min',
187            active boolean default true,
188            channel text not null,
189            nick text not null,
190            private boolean default false,
191            last_update timestamp default 'now()',
192            polls int default 0,
193            updates int default 0
194    );
195    create unique index feeds_url on feeds(url);
196    insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
197            },
198    };
199    
200    foreach my $table ( keys %$sql_schema ) {
201    
202            eval {
203                    $dbh->do(qq{ select count(*) from $table });
204            };
205    
206            if ($@) {
207                    warn "creating database table $table in $DSN\n";
208                    $dbh->do( $sql_schema->{ $table } );
209            }
210    }
211    
212    
213    =head2 meta
214    
215    Set or get some meta data into database
216    
217            meta('nick','channel','var_name', $var_value );
218    
219            $var_value = meta('nick','channel','var_name');
220            ( $var_value, $changed ) = meta('nick','channel','var_name');
221    
222    =cut
223    
224    sub meta {
225            my ($nick,$channel,$name,$value) = @_;
226    
227            # normalize channel name
228            $channel =~ s/^#//;
229    
230            if (defined($value)) {
231    
232                    my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
233    
234                    eval { $sth->execute( $value, $nick, $channel, $name ) };
235    
236                    # error or no result
237                    if ( $@ || ! $sth->rows ) {
238                            $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
239                            $sth->execute( $value, $nick, $channel, $name );
240                            warn "## created $nick/$channel/$name = $value\n";
241                    } else {
242                            warn "## updated $nick/$channel/$name = $value\n";
243                    }
244    
245                    return $value;
246    
247  _SQL_SCHEMA_          } else {
248    
249                    my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
250                    $sth->execute( $nick, $channel, $name );
251                    my ($v,$c) = $sth->fetchrow_array;
252                    warn "## fetched $nick/$channel/$name = $v [$c]\n";
253                    return ($v,$c) if wantarray;
254                    return $v;
255    
256            }
257  }  }
258    
259  my $sth = $dbh->prepare(qq{  
260    
261    my $sth_insert_log = $dbh->prepare(qq{
262  insert into log  insert into log
263          (channel, me, nick, message)          (channel, me, nick, message, time)
264  values (?,?,?,?)  values (?,?,?,?,?)
265  });  });
266    
267    
268    my $tags;
269    
270  =head2 get_from_log  =head2 get_from_log
271    
272   my @messages = get_from_log(   my @messages = get_from_log(
# Line 99  values (?,?,?,?) Line 284  values (?,?,?,?)
284                          # modify message content                          # modify message content
285                          return shift;                          return shift;
286                  }                  }
287          }          },
288            context => 5,
289            full_rows => 1,
290   );   );
291    
292  Order is important. Fields are first passed through C<filter> (if available) and  Order is important. Fields are first passed through C<filter> (if available) and
293  then throgh C<< sprintf($fmt->{message}, $message >> if available.  then throgh C<< sprintf($fmt->{message}, $message >> if available.
294    
295    C<context> defines number of messages around each search hit for display.
296    
297    C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
298    C<me>, C<nick> and C<message> keys.
299    
300  =cut  =cut
301    
302  sub get_from_log {  sub get_from_log {
303          my $args = {@_};          my $args = {@_};
304    
305          $args->{limit} ||= 10;          if ( ! $args->{fmt} ) {
306                    $args->{fmt} = {
307          $args->{fmt} ||= {                          date => '[%s] ',
308                  time => '{%s} ',                          time => '{%s} ',
309                  time_channel => '{%s %s} ',                          time_channel => '{%s %s} ',
310                  nick => '%s: ',                          nick => '%s: ',
311                  me_nick => '***%s ',                          me_nick => '***%s ',
312                  message => '%s',                          message => '%s',
313          };                  };
314            }
315    
316          my $sql = qq{          my $sql_message = qq{
317                  select                  select
318                          time::date as date,                          time::date as date,
319                          time::time as time,                          time::time as time,
# Line 130  sub get_from_log { Line 323  sub get_from_log {
323                          message                          message
324                  from log                  from log
325          };          };
326          $sql .= " where message ilike ? " if ($args->{search});  
327            my $sql_context = qq{
328                    select
329                            id
330                    from log
331            };
332    
333            my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
334    
335            my $sql = $context ? $sql_context : $sql_message;
336    
337            sub check_date {
338                    my $date = shift || return;
339                    my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
340                    if ( $@ ) {
341                            warn "invalid date $date\n";
342                            $new_date = DateTime->now->ymd;
343                    }
344                    return $new_date;
345            }
346    
347            my @where;
348            my @args;
349            my $msg;
350    
351            if (my $search = $args->{search}) {
352                    $search =~ s/^\s+//;
353                    $search =~ s/\s+$//;
354                    push @where, 'message ilike ? or nick ilike ?';
355                    push @args, ( ( '%' . $search . '%' ) x 2 );
356                    $msg = "Search for '$search'";
357            }
358    
359            if ($args->{tag} && $tags->{ $args->{tag} }) {
360                    push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
361                    $msg = "Search for tags $args->{tag}";
362            }
363    
364            if (my $date = $args->{date} ) {
365                    $date = check_date( $date );
366                    push @where, 'date(time) = ?';
367                    push @args, $date;
368                    $msg = "search for date $date";
369            }
370    
371            $sql .= " where " . join(" and ", @where) if @where;
372    
373          $sql .= " order by log.time desc";          $sql .= " order by log.time desc";
374          $sql .= " limit " . $args->{limit};          $sql .= " limit " . $args->{limit} if ($args->{limit});
375    
376            #warn "### sql: $sql ", dump( @args );
377    
378          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
379          if ($args->{search}) {          eval { $sth->execute( @args ) };
380                  $sth->execute( '%' . $args->{search} . '%' );          return if $@;
381                  warn "search for '$args->{search}' returned ", $sth->rows, " results\n";  
382          } else {          my $nr_results = $sth->rows;
383                  $sth->execute();  
         }  
384          my $last_row = {          my $last_row = {
385                  date => '',                  date => '',
386                  time => '',                  time => '',
# Line 154  sub get_from_log { Line 394  sub get_from_log {
394                  unshift @rows, $row;                  unshift @rows, $row;
395          }          }
396    
397          my @msgs = (          # normalize nick names
398                  "Showing " . ($#rows + 1) . " messages..."          map {
399                    $_->{nick} =~ s/^_*(.*?)_*$/$1/
400            } @rows;
401    
402            return @rows if ($args->{full_rows});
403    
404            $msg .= ' produced ' . (
405                    $nr_results == 0 ? 'no results' :
406                    $nr_results == 0 ? 'one result' :
407                            $nr_results . ' results'
408          );          );
409    
410            my @msgs = ( $msg );
411    
412            if ($context) {
413                    my @ids = @rows;
414                    @rows = ();
415    
416                    my $last_to = 0;
417    
418                    my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
419                    foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
420                            my $id = $row_id->{id} || die "can't find id in row";
421            
422                            my ($from, $to) = ($id - $context, $id + $context);
423                            $from = $last_to if ($from < $last_to);
424                            $last_to = $to;
425                            $sth->execute( $from, $to );
426    
427                            #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
428    
429                            while (my $row = $sth->fetchrow_hashref) {
430                                    push @rows, $row;
431                            }
432    
433                    }
434            }
435    
436            # sprintf which can take coderef as first parametar
437            sub cr_sprintf {
438                    my $fmt = shift || return;
439                    if (ref($fmt) eq 'CODE') {
440                            $fmt->(@_);
441                    } else {
442                            sprintf($fmt, @_);
443                    }
444            }
445    
446          foreach my $row (@rows) {          foreach my $row (@rows) {
447    
448                  $row->{time} =~ s#\.\d+##;                  $row->{time} =~ s#\.\d+##;
449    
                 my $t;  
                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                 $t .= $row->{time};  
   
450                  my $msg = '';                  my $msg = '';
451    
452                    $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
453                    my $t = $row->{time};
454    
455                  if ($last_row->{channel} ne $row->{channel}) {                  if ($last_row->{channel} ne $row->{channel}) {
456                          $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});                          $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
457                  } else {                  } else {
458                          $msg .= sprintf($args->{fmt}->{time}, $t);                          $msg .= cr_sprintf($args->{fmt}->{time}, $t);
459                  }                  }
460    
461                  my $append = 1;                  my $append = 1;
462    
463                  if ($last_row->{nick} ne $row->{nick}) {                  my $nick = $row->{nick};
464    #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
465    #                       $row->{nick} = $nick;
466    #               }
467    
468                    $append = 0 if $row->{me};
469    
470                    if ($last_row->{nick} ne $nick) {
471                          # 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
472                          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};
473                          $fmt ||= '%s';                          $fmt ||= '%s';
474    
                         my $nick = $row->{nick};  
475                          $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');                          $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
476    
477                          $msg .= sprintf( $fmt, $nick );                          $msg .= cr_sprintf( $fmt, $nick );
478                          $append = 0;                          $append = 0;
479                  }                  }
480    
481                  $args->{fmt}->{message} ||= '%s';                  $args->{fmt}->{message} ||= '%s';
482                  if (ref($args->{filter}->{message}) eq 'CODE') {                  if (ref($args->{filter}->{message}) eq 'CODE') {
483                          $msg .= sprintf($args->{fmt}->{message},                          $msg .= cr_sprintf($args->{fmt}->{message},
484                                  $args->{filter}->{message}->(                                  $args->{filter}->{message}->(
485                                          $row->{message}                                          $row->{message}
486                                  )                                  )
487                          );                          );
488                  } else {                  } else {
489                          $msg .= sprintf($args->{fmt}->{message}, $row->{message});                          $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
490                  }                  }
491    
492                  if ($append && @msgs) {                  if ($append && @msgs) {
# Line 211  sub get_from_log { Line 501  sub get_from_log {
501          return @msgs;          return @msgs;
502  }  }
503    
504    # tags support
505    
506    my $cloud = HTML::TagCloud->new;
507    
508    =head2 add_tag
509    
510     add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
511    
512    =cut
513    
514    my @last_tags;
515    
516    sub add_tag {
517            my $arg = {@_};
518    
519            return unless ($arg->{id} && $arg->{message});
520    
521            my $m = $arg->{message};
522    
523  my $SKIPPING = 0;               # if skipping, how many we've done          my @tags;
524  my $SEND_QUEUE;                 # cache  
525            while ($m =~ s#$tag_regex##s) {
526                    my $tag = $1;
527                    next if (! $tag || $tag =~ m/https?:/i);
528                    push @{ $tags->{$tag} }, $arg->{id};
529                    #warn "+tag $tag: $arg->{id}\n";
530                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
531                    push @tags, $tag;
532    
533            }
534    
535            if ( @tags ) {
536                    pop @last_tags if $#last_tags == $last_x_tags;
537                    unshift @last_tags, { tags => [ @tags ], %$arg };
538            }
539    
540    }
541    
542    =head2 seed_tags
543    
544    Read all tags from database and create in-memory cache for tags
545    
546    =cut
547    
548    sub seed_tags {
549            my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
550            $sth->execute;
551            while (my $row = $sth->fetchrow_hashref) {
552                    add_tag( %$row );
553            }
554    
555            foreach my $tag (keys %$tags) {
556                    $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
557            }
558    }
559    
560    seed_tags;
561    
562    
563    =head2 save_message
564    
565      save_message(
566            channel => '#foobar',
567            me => 0,
568            nick => 'dpavlin',
569            message => 'test message',
570            time => '2006-06-25 18:57:18',
571      );
572    
573    C<time> is optional, it will use C<< now() >> if it's not available.
574    
575    C<me> if not specified will be C<0> (not C</me> message)
576    
577    =cut
578    
579    sub save_message {
580            my $a = {@_};
581            confess "have msg" if $a->{msg};
582            $a->{me} ||= 0;
583            $a->{time} ||= strftime($TIMESTAMP,localtime());
584    
585            _log
586                    $a->{channel}, " ",
587                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
588                    " " . $a->{message};
589    
590            $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
591            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
592    }
593    
594    
595    if ($import_dircproxy) {
596            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
597            warn "importing $import_dircproxy...\n";
598            my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
599            while(<$l>) {
600                    chomp;
601                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
602                            my ($time, $nick, $msg) = ($1,$2,$3);
603    
604                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
605    
606                            my $me = 0;
607                            $me = 1 if ($nick =~ m/^\[\S+]/);
608                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
609    
610                            $msg =~ s/^ACTION\s+// if ($me);
611    
612                            save_message(
613                                    channel => $CHANNEL,
614                                    me => $me,
615                                    nick => $nick,
616                                    message => $msg,
617                                    time => $dt->ymd . " " . $dt->hms,
618                            ) if ($nick !~ m/^-/);
619    
620                    } else {
621                            _log "can't parse: $_";
622                    }
623            }
624            close($l);
625            warn "import over\n";
626            exit;
627    }
628    
629    #
630    # RSS follow
631    #
632    
633    my $_rss;
634    
635    
636    sub rss_fetch {
637            my ($args) = @_;
638    
639            # how many messages to send out when feed is seen for the first time?
640            my $send_rss_msgs = 1;
641    
642            _log "RSS fetch", $args->{url};
643    
644            my $feed = XML::Feed->parse(URI->new( $args->{url} ));
645            if ( ! $feed ) {
646                    _log("can't fetch RSS ", $args->{url});
647                    return;
648            }
649    
650            my ( $total, $updates ) = ( 0, 0 );
651            for my $entry ($feed->entries) {
652                    $total++;
653    
654                    # seen allready?
655                    next if $_rss->{$args->{channel}}->{$feed->link}->{$entry->id}++ > 0;
656    
657                    sub prefix {
658                            my ($txt,$var) = @_;
659                            $var =~ s/\s+/ /gs;
660                            $var =~ s/^\s+//g;
661                            $var =~ s/\s+$//g;
662                            return $txt . $var if $var;
663                    }
664    
665                    # fix absolute and relative links to feed entries
666                    my $link = $entry->link;
667                    if ( $link =~ m!^/! ) {
668                            my $host = $args->{url};
669                            $host =~ s!^(http://[^/]+).*$!$1!;      #!vim
670                            $link = "$host/$link";
671                    } elsif ( $link !~ m!^http! ) {
672                            $link = $args->{url} . $link;
673                    }
674    
675                    my $msg;
676                    $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
677                    $msg .= prefix( ' by ' , $entry->author );
678                    $msg .= prefix( ' | ' , $entry->title );
679                    $msg .= prefix( ' | ' , $link );
680    #               $msg .= prefix( ' id ' , $entry->id );
681    
682                    if ( $args->{kernel} && $send_rss_msgs ) {
683                            $send_rss_msgs--;
684                            # FIXME bug! should be save_message
685    #                       save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
686                            $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
687                            my ( $type, $to ) = ( 'notice', $args->{channel} );
688                            ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
689                            _log(">> $type $to |", $msg);
690                            $args->{kernel}->post( $IRC_ALIAS => $type => $to, $msg );
691                            $updates++;
692                    }
693            }
694    
695            my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
696            $sql .= qq{, updates = updates + $updates } if $updates;
697            $sql .= qq{where id = } . $args->{id};
698            eval { $dbh->do( $sql ) };
699    
700            _log "RSS got $total items of which $updates new";
701    
702            return $updates;
703    }
704    
705    sub rss_fetch_all {
706            my $kernel = shift;
707            my $sql = qq{
708                    select id, url, name, channel, nick, private
709                    from feeds
710                    where active is true
711            };
712            # limit to newer feeds only if we are not sending messages out
713            $sql .= qq{     and last_update + delay < now() } if $kernel;
714            my $sth = $dbh->prepare( $sql );
715            $sth->execute();
716            warn "# ",$sth->rows," active RSS feeds\n";
717            my $count = 0;
718            while (my $row = $sth->fetchrow_hashref) {
719                    $row->{kernel} = $kernel if $kernel;
720                    $count += rss_fetch( $row );
721            }
722            return "OK, fetched $count posts from " . $sth->rows . " feeds";
723    }
724    
725    
726    sub rss_check_updates {
727            my $kernel = shift;
728            $_rss->{last_poll} ||= time();
729            my $dt = time() - $_rss->{last_poll};
730            warn "## rss_check_updates $dt > $rss_min_delay\n";
731            if ( $dt > $rss_min_delay ) {
732                    $_rss->{last_poll} = time();
733                    _log rss_fetch_all( $kernel );
734            }
735    }
736    
737    # seed rss seen cache so we won't send out all items on startup
738    _log rss_fetch_all;
739    
740    #
741    # POE handing part
742    #
743    
744    my $ping;                                               # ping stats
745    
746  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
747    
748  POE::Session->create  POE::Session->create( inline_states => {
749    (inline_states =>          _start => sub {      
    {_start => sub {        
750                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
751                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
752      },      },
753      irc_255 => sub {    # server is done blabbing      irc_255 => sub {    # server is done blabbing
754                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
                 $_[KERNEL]->post($IRC_ALIAS => join => '#logger');  
                 $_[KERNEL]->yield("heartbeat"); # start heartbeat  
 #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  
755                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
756      },      },
757      irc_public => sub {      irc_public => sub {
# Line 236  POE::Session->create Line 760  POE::Session->create
760                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
761                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
762    
763                  from_to($msg, 'UTF-8', $ENCODING);                  save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
764                    meta( $nick, $channel, 'last-msg', $msg );
765                  print "$channel: <$nick> $msg\n";                  rss_check_updates( $kernel );
                 $sth->execute($channel, 0, $nick, $msg);  
766      },      },
767      irc_ctcp_action => sub {      irc_ctcp_action => sub {
768                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 247  POE::Session->create Line 770  POE::Session->create
770                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
771                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
772    
773                  from_to($msg, 'UTF-8', $ENCODING);                  save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
774    
775                    if ( $use_twitter ) {
776                            if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
777                                    my ($login,$passwd) = split(/\s+/,$twitter,2);
778                                    _log("sending twitter for $nick/$login on $channel ");
779                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
780                                    $bot->update("<${channel}> $msg");
781                            }
782                    }
783    
                 print "$channel ***$nick $msg\n";  
                 $sth->execute($channel, 1, $nick, $msg);  
784      },      },
785            irc_ping => sub {
786                    _log( "pong ", $_[ARG0] );
787                    $ping->{ $_[ARG0] }++;
788                    rss_check_updates( $_[KERNEL] );
789            },
790            irc_invite => sub {
791                    my $kernel = $_[KERNEL];
792                    my $nick = (split /!/, $_[ARG0])[0];
793                    my $channel = $_[ARG1];
794    
795                    _log "invited to $channel by $nick";
796    
797                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
798                    $_[KERNEL]->post($IRC_ALIAS => join => $channel);
799    
800            },
801          irc_msg => sub {          irc_msg => sub {
802                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
803                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
804                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
805                  from_to($msg, 'UTF-8', $ENCODING);                  my $channel = $_[ARG1]->[0];
806    
807                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
808                  my @out;                  my @out;
809    
810                  print "<< $msg\n";                  _log "<< $msg";
811    
812                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
813    
# Line 269  POE::Session->create Line 815  POE::Session->create
815    
816                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
817    
818                          print ">> /msg $1 $2\n";                          _log ">> /msg $1 $2";
819                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
820                          $res = '';                          $res = '';
821    
# Line 278  POE::Session->create Line 824  POE::Session->create
824                          my $nr = $1 || 10;                          my $nr = $1 || 10;
825    
826                          my $sth = $dbh->prepare(qq{                          my $sth = $dbh->prepare(qq{
827                                  select nick,count(*) from log group by nick order by count desc limit $nr                                  select
828                                            trim(both '_' from nick) as nick,
829                                            count(*) as count,
830                                            sum(length(message)) as len
831                                    from log
832                                    group by trim(both '_' from nick)
833                                    order by len desc,count desc
834                                    limit $nr
835                          });                          });
836                          $sth->execute();                          $sth->execute();
837                          $res = "Top $nr users: ";                          $res = "Top $nr users: ";
838                          my @users;                          my @users;
839                          while (my $row = $sth->fetchrow_hashref) {                          while (my $row = $sth->fetchrow_hashref) {
840                                  push @users,$row->{nick} . ': ' . $row->{count};                                  push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
841                          }                          }
842                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
843                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
844    
845                          foreach my $res (get_from_log( limit => $1 )) {                          my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
846                                  print "last: $res\n";  
847                                  from_to($res, $ENCODING, 'UTF-8');                          foreach my $res (get_from_log( limit => $limit )) {
848                                    _log "last: $res";
849                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
850                          }                          }
851    
852                          $res = '';                          $res = '';
853    
854                  } elsif ($msg =~ m/^(search|grep)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
855    
856                          my $what = $2;                          my $what = $2;
857    
858                          foreach my $res (get_from_log( limit => 20, search => $what )) {                          foreach my $res (get_from_log(
859                                  print "search [$what]: $res\n";                                          limit => 20,
860                                  from_to($res, $ENCODING, 'UTF-8');                                          search => $what,
861                                    )) {
862                                    _log "search [$what]: $res";
863                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
864                          }                          }
865    
866                          $res = '';                          $res = '';
867    
868                    } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
869    
870                            my ($what,$limit) = ($1,$2);
871                            $limit ||= 100;
872    
873                            my $stat;
874    
875                            foreach my $res (get_from_log(
876                                            limit => $limit,
877                                            search => $what,
878                                            full_rows => 1,
879                                    )) {
880                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
881                                            $stat->{vote}->{$1}++;
882                                            $stat->{from}->{ $res->{nick} }++;
883                                    }
884                            }
885    
886                            my @nicks;
887                            foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
888                                    push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
889                                            "(" . $stat->{from}->{$nick} . ")"
890                                    );
891                            }
892    
893                            $res =
894                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
895                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
896                                    " from " . ( join(", ", @nicks) || 'nobody' );
897    
898                            $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
899    
900                    } elsif ($msg =~ m/^ping/) {
901                            $res = "ping = " . dump( $ping );
902                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
903                            if ( ! defined( $1 ) ) {
904                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
905                                    $sth->execute( $nick, $channel );
906                                    $res = "config for $nick on $channel";
907                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
908                                            $res .= " | $n = $v";
909                                    }
910                            } elsif ( ! $2 ) {
911                                    my $val = meta( $nick, $channel, $1 );
912                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
913                            } else {
914                                    my $validate = {
915                                            'last-size' => qr/^\d+/,
916                                            'twitter' => qr/^\w+\s+\w+/,
917                                    };
918    
919                                    my ( $op, $val ) = ( $1, $2 );
920    
921                                    if ( my $regex = $validate->{$op} ) {
922                                            if ( $val =~ $regex ) {
923                                                    meta( $nick, $channel, $op, $val );
924                                                    $res = "saved $op = $val";
925                                            } else {
926                                                    $res = "config option $op = $val doesn't validate against $regex";
927                                            }
928                                    } else {
929                                            $res = "config option $op doesn't exist";
930                                    }
931                            }
932                    } elsif ($msg =~ m/^rss-update/) {
933                            $res = rss_fetch_all( $_[KERNEL] );
934                    } elsif ($msg =~ m/^rss-clean/) {
935                            $_rss = undef;
936                            $dbh->do( qq{ update feeds set last_update = now() - delay } );
937                            $res = "OK, cleaned RSS cache";
938                    } elsif ($msg =~ m/^rss-list/) {
939                            my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
940                            $sth->execute;
941                            while (my @row = $sth->fetchrow_array) {
942                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
943                            }
944                            $res = '';
945                    } elsif ($msg =~ m!^rss-(add|remove|stop|start)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
946                            my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
947    
948                            my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
949                            $channel = $nick if $sub eq 'private';
950    
951                            my $sql = {
952                                    add     => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
953    #                               remove  => qq{ delete from feeds                                where url = ? and name = ? },
954                                    start   => qq{ update feeds set active = true   where url = ? },
955                                    stop    => qq{ update feeds set active = false  where url = ? },
956                            };
957    
958                            if ( $command eq 'add' && ! $channel ) {
959                                    $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
960                            } elsif (my $q = $sql->{$command} ) {
961                                    my $sth = $dbh->prepare( $q );
962                                    my @data = ( $url );
963                                    if ( $command eq 'add' ) {
964                                            push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
965                                    }
966                                    warn "## $command SQL $q with ",dump( @data ),"\n";
967                                    eval { $sth->execute( @data ) };
968                                    if ($@) {
969                                            $res = "ERROR: $@";
970                                    } else {
971                                            $res = "OK, RSS [$command|$sub|$url|$arg]";
972                                    }
973                            } else {
974                                    $res = "ERROR: don't know what to do with: $msg";
975                            }
976                  }                  }
977    
978                  if ($res) {                  if ($res) {
979                          print ">> [$nick] $res\n";                          _log ">> [$nick] $res";
                         from_to($res, $ENCODING, 'UTF-8');  
980                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
981                  }                  }
982    
983                    rss_check_updates( $_[KERNEL] );
984          },          },
985          irc_477 => sub {          irc_477 => sub {
986                  print "# irc_477: ",$_[ARG1], "\n";                  _log "<< irc_477: ",$_[ARG1];
987                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
988          },          },
989          irc_505 => sub {          irc_505 => sub {
990                  print "# irc_505: ",$_[ARG1], "\n";                  _log "<< irc_505: ",$_[ARG1];
991                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
992  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
993  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
994          },          },
995          irc_registered => sub {          irc_registered => sub {
996                  warn "## indetify $NICK\n";                  _log "## registrated $NICK, /msg nickserv IDENTIFY $NICK";
997                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
998          },          },
999            irc_disconnected => sub {
1000                    _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1001                    sleep($sleep_on_error);
1002                    $_[KERNEL]->post( $IRC_ALIAS => connect => $CONNECT);
1003            },
1004            irc_socketerr => sub {
1005                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1006                    sleep($sleep_on_error);
1007                    $_[KERNEL]->post( $IRC_ALIAS => connect => $CONNECT);
1008            },
1009  #       irc_433 => sub {  #       irc_433 => sub {
1010  #               print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
1011  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
1012  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
1013  #       },  #       },
1014          irc_372 => sub {  #       irc_451 # please register
                 print "MOTD: ", $_[ARG1], "\n";  
         },  
1015          irc_snotice => sub {          irc_snotice => sub {
1016                  print "(server notice): ", $_[ARG0], "\n";                  _log "<< snotice",$_[ARG0];
1017                    if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1018                            warn ">> $1 | $2\n";
1019                            $_[KERNEL]->post( $IRC_ALIAS => lc($1) => $2);
1020                    }
1021          },          },
     (map  
      {  
        ;"irc_$_" => sub { }}  
      qw(  
                 )),  
 #       join  
 #       ctcp_version  
 #       connected snotice ctcp_action ping notice mode part quit  
 #       001 002 003 004 005  
 #       250 251 252 253 254 265 266  
 #       332 333 353 366 372 375 376  
 #       477  
1022      _child => sub {},      _child => sub {},
1023      _default => sub {      _default => sub {
1024        printf "%s: session %s caught an unhandled %s event.\n",                  _log sprintf "sID:%s %s %s",
1025          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          $_[SESSION]->ID, $_[ARG0],
1026        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
1027          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
1028                            "";
1029        0;                        # false for signals        0;                        # false for signals
1030      },      },
     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);  
     }  
1031     },     },
1032    );    );
1033    
1034  # http server  # http server
1035    
1036  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
1037          Port => $NICK =~ m/-dev/ ? 8001 : 8000,          Port => $http_port,
1038            PreHandler => {
1039                    '/' => sub {
1040                            $_[0]->header(Connection => 'close')
1041                    }
1042            },
1043          ContentHandler => { '/' => \&root_handler },          ContentHandler => { '/' => \&root_handler },
1044          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
1045  );  );
1046    
 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
 my $escape_re  = join '|' => keys %escape;  
   
1047  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
1048  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
1049  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
1050    .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1051  .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 ; }
1052  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
1053  .search { float: right; }  .search { float: right; }
1054    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1055    a:hover.tag { border: 1px solid #eee }
1056    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1057    /*
1058  .col-0 { background: #ffff66 }  .col-0 { background: #ffff66 }
1059  .col-1 { background: #a0ffff }  .col-1 { background: #a0ffff }
1060  .col-2 { background: #99ff99 }  .col-2 { background: #99ff99 }
1061  .col-3 { background: #ff9999 }  .col-3 { background: #ff9999 }
1062  .col-4 { background: #ff66ff }  .col-4 { background: #ff66ff }
1063    */
1064    .calendar { border: 1px solid red; width: 100%; }
1065    .month { border: 0px; width: 100%; }
1066  _END_OF_STYLE_  _END_OF_STYLE_
1067    
1068  my $max_color = 4;  $max_color = 0;
1069    
1070  my %nick_enumerator;  my @cols = qw(
1071            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1072            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1073            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1074            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1075            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1076    );
1077    
1078    foreach my $c (@cols) {
1079            $style .= ".col-${max_color} { background: $c }\n";
1080            $max_color++;
1081    }
1082    warn "defined $max_color colors for users...\n";
1083    
1084  sub root_handler {  sub root_handler {
1085          my ($request, $response) = @_;          my ($request, $response) = @_;
1086          $response->code(RC_OK);          $response->code(RC_OK);
1087          $response->content_type("text/html; charset=$ENCODING");  
1088            # this doesn't seem to work, so moved to PreHandler
1089            #$response->header(Connection => 'close');
1090    
1091            return RC_OK if $request->uri =~ m/favicon.ico$/;
1092    
1093          my $q;          my $q;
1094    
# Line 471  sub root_handler { Line 1102  sub root_handler {
1102    
1103          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
1104    
1105          $response->content(          if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1106                  qq{<html><head><title>$NICK</title><style type="text/css">$style</style></head><body>                  my $show = lc($1);
1107                  <form method="post" class="search">                  my $nr = $2;
1108    
1109                    my $type = 'RSS';       # Atom
1110    
1111                    $response->content_type( 'application/' . lc($type) . '+xml' );
1112    
1113                    my $html = '<!-- error -->';
1114                    #warn "create $type feed from ",dump( @last_tags );
1115    
1116                    my $feed = XML::Feed->new( $type );
1117                    $feed->link( $url );
1118    
1119                    if ( $show eq 'tags' ) {
1120                            $nr ||= 50;
1121                            $feed->title( "tags from $CHANNEL" );
1122                            $feed->link( "$url/tags" );
1123                            $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1124                            my $feed_entry = XML::Feed::Entry->new($type);
1125                            $feed_entry->title( "$nr tags from $CHANNEL" );
1126                            $feed_entry->author( $NICK );
1127                            $feed_entry->link( '/#tags'  );
1128    
1129                            $feed_entry->content(
1130                                    qq{<![CDATA[<style type="text/css">}
1131                                    . $cloud->css
1132                                    . qq{</style>}
1133                                    . $cloud->html( $nr )
1134                                    . qq{]]>}
1135                            );
1136                            $feed->add_entry( $feed_entry );
1137    
1138                    } elsif ( $show eq 'last-tag' ) {
1139    
1140                            $nr ||= $last_x_tags;
1141                            $nr = $last_x_tags if $nr > $last_x_tags;
1142    
1143                            $feed->title( "last $nr tagged messages from $CHANNEL" );
1144                            $feed->description( "collects messages which have tags// in them" );
1145    
1146                            foreach my $m ( @last_tags ) {
1147    #                               warn dump( $m );
1148                                    #my $tags = join(' ', @{$m->{tags}} );
1149                                    my $feed_entry = XML::Feed::Entry->new($type);
1150                                    $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1151                                    $feed_entry->author( $m->{nick} );
1152                                    $feed_entry->link( '/#' . $m->{id}  );
1153                                    $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1154    
1155                                    my $message = $filter->{message}->( $m->{message} );
1156                                    $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1157    #                               warn "## message = $message\n";
1158    
1159                                    #$feed_entry->summary(
1160                                    $feed_entry->content(
1161                                            "<![CDATA[$message]]>"
1162                                    );
1163                                    $feed_entry->category( join(', ', @{$m->{tags}}) );
1164                                    $feed->add_entry( $feed_entry );
1165    
1166                                    $nr--;
1167                                    last if $nr <= 0;
1168    
1169                            }
1170    
1171                    } elsif ( $show =~ m/^follow/ ) {
1172    
1173                            $feed->title( "Feeds which this bot follows" );
1174    
1175                            my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1176                            $sth->execute;
1177                            while (my $row = $sth->fetchrow_hashref) {
1178                                    my $feed_entry = XML::Feed::Entry->new($type);
1179                                    $feed_entry->title( $row->{name} );
1180                                    $feed_entry->link( $row->{url}  );
1181                                    $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1182                                    $feed_entry->content(
1183                                            '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1184                                    );
1185                                    $feed->add_entry( $feed_entry );
1186                            }
1187    
1188                            my $feed_entry = XML::Feed::Entry->new($type);
1189                            $feed_entry->title( "Internal stats" );
1190                            $feed_entry->content(
1191                                    '<![CDATA[<pre>' . dump( $_rss ) . '</pre>]]>'
1192                            );
1193                            $feed->add_entry( $feed_entry );
1194    
1195                    } else {
1196                            _log "unknown rss request ",$request->url;
1197                            return RC_DENY;
1198                    }
1199    
1200                    $response->content( $feed->as_xml );
1201                    return RC_OK;
1202            }
1203    
1204            if ( $@ ) {
1205                    warn "$@";
1206            }
1207    
1208            $response->content_type("text/html; charset=UTF-8");
1209    
1210            my $html =
1211                    qq{<html><head><title>$NICK</title><style type="text/css">$style}
1212                    . $cloud->css
1213                    . qq{</style></head><body>}
1214                    . qq{
1215                    <form method="post" class="search" action="/">
1216                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
1217                  <input type="submit" value="search">                  <input type="submit" value="search">
1218                  </form>                  </form>
1219                  <p>                  }
1220                  } .                  . $cloud->html(500)
1221                  join("</p><p>",                  . qq{<p>};
1222    
1223            if ($request->url =~ m#/tags?#) {
1224                    # nop
1225            } elsif ($request->url =~ m#/history#) {
1226                    my $sth = $dbh->prepare(qq{
1227                            select date(time) as date,count(*) as nr,sum(length(message)) as len
1228                                    from log
1229                                    group by date(time)
1230                                    order by date(time) desc
1231                    });
1232                    $sth->execute();
1233                    my ($l_yyyy,$l_mm) = (0,0);
1234                    $html .= qq{<table class="calendar"><tr>};
1235                    my $cal;
1236                    my $ord = 0;
1237                    while (my $row = $sth->fetchrow_hashref) {
1238                            # this is probably PostgreSQL specific, expects ISO date
1239                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1240                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
1241                                    if ( $cal ) {
1242                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1243                                            $ord++;
1244                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1245                                    }
1246                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1247                                    $cal->border(1);
1248                                    $cal->width('30%');
1249                                    $cal->cellheight('5em');
1250                                    $cal->tableclass('month');
1251                                    #$cal->cellclass('day');
1252                                    $cal->sunday('SUN');
1253                                    $cal->saturday('SAT');
1254                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
1255                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
1256                            }
1257                            $cal->setcontent($dd, qq[
1258                                    <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1259                            ]) if $cal;
1260                            
1261                    }
1262                    $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1263    
1264            } else {
1265                    $html .= join("</p><p>",
1266                          get_from_log(                          get_from_log(
1267                                  limit => $q->param('limit') || 100,                                  limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1268                                  search => $q->param('search') || $q->param('grep') || undef,                                  search => $search || undef,
1269                                    tag => $q->param('tag') || undef,
1270                                    date => $q->param('date') || undef,
1271                                  fmt => {                                  fmt => {
1272                                            date => sub {
1273                                                    my $date = shift || return;
1274                                                    qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1275                                            },
1276                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
1277                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
1278                                          nick => '%s:&nbsp;',                                          nick => '%s:&nbsp;',
1279                                          me_nick => '***%s&nbsp;',                                          me_nick => '***%s&nbsp;',
1280                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
1281                                  },                                  },
1282                                  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;  
                                                 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>';  
                                         },  
                                 },  
1283                          )                          )
1284                  ) .                  );
1285                  qq{</p></body></html>}          }
1286          );  
1287            $html .= qq{</p>
1288            <hr/>
1289            <p>See <a href="/history">history</a> of all messages.</p>
1290            </body></html>};
1291    
1292            $response->content( $html );
1293            warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1294          return RC_OK;          return RC_OK;
1295  }  }
1296    
Legend:
Removed from v.20  
changed lines
  Added in v.105
  ViewVC Help
Powered by ViewVC 1.1.26