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

Annotation of /trunk/bin/irc-logger.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 150 - (hide annotations)
Sat Oct 8 18:43:21 2011 UTC (9 years, 3 months ago) by dpavlin
File MIME type: text/plain
File size: 38339 byte(s)
import only messages newer than last message in log
1 dpavlin 4 #!/usr/bin/perl -w
2     use strict;
3     $|++;
4    
5 dpavlin 122 use POE qw(Component::IRC Component::Server::HTTP Component::Client::HTTP);
6 dpavlin 102 use HTTP::Status;
7     use DBI;
8     use Regexp::Common qw /URI/;
9     use CGI::Simple;
10     use POSIX qw/strftime/;
11     use HTML::CalendarMonthSimple;
12     use Getopt::Long;
13     use DateTime;
14     use URI::Escape;
15     use Data::Dump qw/dump/;
16     use DateTime::Format::ISO8601;
17     use Carp qw/confess/;
18     use XML::Feed;
19     use DateTime::Format::Flexible;
20 dpavlin 123 use Encode;
21 dpavlin 149 #use Redis 2.0;
22 dpavlin 102
23 dpavlin 5 =head1 NAME
24    
25     irc-logger.pl
26    
27     =head1 SYNOPSIS
28    
29     ./irc-logger.pl
30    
31 dpavlin 37 =head2 Options
32    
33     =over 4
34    
35     =item --import-dircproxy=filename
36    
37     Import log from C<dircproxy> to C<irc-logger> database
38    
39 dpavlin 45 =item --log=irc-logger.log
40    
41     =back
42    
43 dpavlin 5 =head1 DESCRIPTION
44    
45     log all conversation on irc channel
46    
47     =cut
48    
49 dpavlin 4 ## CONFIG
50    
51 dpavlin 119 my $debug = 0;
52    
53 dpavlin 109 my $irc_config = {
54     nick => 'irc-logger',
55     server => 'irc.freenode.net',
56     port => 6667,
57     ircname => 'Anna the bot: try /msg irc-logger help',
58     };
59    
60 dpavlin 73 my $HOSTNAME = `hostname -f`;
61     chomp($HOSTNAME);
62 dpavlin 33
63 dpavlin 109
64 dpavlin 4 my $CHANNEL = '#razmjenavjestina';
65    
66 dpavlin 109 if ( $HOSTNAME =~ m/llin/ ) {
67 dpavlin 114 $irc_config->{nick} = 'irc-logger-llin';
68 dpavlin 109 # $irc_config = {
69 dpavlin 114 # nick => 'irc-logger-llin',
70 dpavlin 109 # server => 'localhost',
71     # port => 6668,
72     # };
73     $CHANNEL = '#irc-logger';
74     } elsif ( $HOSTNAME =~ m/lugarin/ ) {
75     $irc_config->{server} = 'irc.carnet.hr';
76 dpavlin 102 $CHANNEL = '#riss';
77     }
78    
79 dpavlin 109 my @channels = ( $CHANNEL );
80 dpavlin 102
81 dpavlin 122 warn "## config = ", dump( $irc_config ) if $debug;
82 dpavlin 109
83     my $NICK = $irc_config->{nick} or die "no nick?";
84    
85 dpavlin 19 my $DSN = 'DBI:Pg:dbname=' . $NICK;
86 dpavlin 5
87 dpavlin 34 my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
88 dpavlin 14
89 dpavlin 41 my $sleep_on_error = 5;
90    
91 dpavlin 79 # number of last tags to keep in circular buffer
92     my $last_x_tags = 50;
93    
94 dpavlin 85 # don't pull rss feeds more often than this
95     my $rss_min_delay = 60;
96    
97 dpavlin 70 my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
98    
99 dpavlin 73 my $url = "http://$HOSTNAME:$http_port";
100    
101 dpavlin 4 ## END CONFIG
102    
103 dpavlin 54 my $use_twitter = 1;
104     eval { require Net::Twitter; };
105     $use_twitter = 0 if ($@);
106    
107 dpavlin 37 my $import_dircproxy;
108 dpavlin 45 my $log_path;
109 dpavlin 37 GetOptions(
110     'import-dircproxy:s' => \$import_dircproxy,
111 dpavlin 45 'log:s' => \$log_path,
112 dpavlin 122 'debug!' => \$debug,
113 dpavlin 37 );
114    
115 dpavlin 87 #$SIG{__DIE__} = sub {
116     # confess "fatal error";
117     #};
118 dpavlin 68
119 dpavlin 45 sub _log {
120 dpavlin 116 print strftime($TIMESTAMP,localtime()) . ' ' . join(" ",map { ref($_) ? dump( $_ ) : $_ } @_) . $/;
121 dpavlin 45 }
122    
123 dpavlin 116 open(STDOUT, '>', $log_path) && warn "log to $log_path: $!\n";
124    
125 dpavlin 119
126 dpavlin 70 # HTML formatters
127    
128     my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
129     my $escape_re = join '|' => keys %escape;
130    
131 dpavlin 133 my $tag_regex = '\b([\w\-_]+)//';
132 dpavlin 70
133     my %nick_enumerator;
134     my $max_color = 0;
135    
136     my $filter = {
137     message => sub {
138     my $m = shift || return;
139    
140     # protect HTML from wiki modifications
141     sub e {
142     my $t = shift;
143 dpavlin 141 eval { $t = 'uri_unescape{' . uri_escape($t, '^a-zA-Z0-9') . '}'; };
144     return $t;
145 dpavlin 70 }
146    
147     $m =~ s/($escape_re)/$escape{$1}/gs;
148 dpavlin 98 $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
149 dpavlin 142 # $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
150 dpavlin 73 $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
151 dpavlin 70 $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
152     $m =~ s#_(\w+)_#<u>$1</u>#gs;
153    
154     $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
155     return $m;
156     },
157     nick => sub {
158     my $n = shift || return;
159     if (! $nick_enumerator{$n}) {
160     my $max = scalar keys %nick_enumerator;
161     $nick_enumerator{$n} = $max + 1;
162     }
163     return '<span class="nick col-' .
164     ( $nick_enumerator{$n} % $max_color ) .
165     '">' . $n . '</span>';
166     },
167     };
168    
169 dpavlin 112 # POE IRC
170     my $poe_irc = POE::Component::IRC->spawn( %$irc_config ) or
171     die "can't start ", dump( $irc_config ), ": $!";
172    
173     my $irc = $poe_irc->session_id();
174     _log "IRC session_id $irc";
175    
176 dpavlin 5 my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
177 dpavlin 88 $dbh->do( qq{ set client_encoding = 'UTF-8' } );
178 dpavlin 5
179 dpavlin 50 my $sql_schema = {
180 dpavlin 85 log => qq{
181 dpavlin 5 create table log (
182     id serial,
183     time timestamp default now(),
184     channel text not null,
185 dpavlin 19 me boolean default false,
186 dpavlin 5 nick text not null,
187     message text not null,
188     primary key(id)
189     );
190    
191     create index log_time on log(time);
192     create index log_channel on log(channel);
193     create index log_nick on log(nick);
194 dpavlin 85 },
195     meta => q{
196 dpavlin 50 create table meta (
197     nick text not null,
198     channel text not null,
199     name text not null,
200     value text,
201 dpavlin 85 changed timestamp default 'now()',
202 dpavlin 50 primary key(nick,channel,name)
203     );
204 dpavlin 85 },
205     feeds => qq{
206     create table feeds (
207     id serial,
208     url text not null,
209     name text,
210 dpavlin 86 delay interval not null default '5 min',
211 dpavlin 85 active boolean default true,
212 dpavlin 97 channel text not null,
213     nick text not null,
214     private boolean default false,
215 dpavlin 85 last_update timestamp default 'now()',
216     polls int default 0,
217     updates int default 0
218     );
219     create unique index feeds_url on feeds(url);
220 dpavlin 97 insert into feeds (url,name,channel,nick) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki','$CHANNEL','dpavlin');
221 dpavlin 85 },
222 dpavlin 50 };
223 dpavlin 5
224 dpavlin 50 foreach my $table ( keys %$sql_schema ) {
225    
226     eval {
227     $dbh->do(qq{ select count(*) from $table });
228     };
229    
230     if ($@) {
231     warn "creating database table $table in $DSN\n";
232     $dbh->do( $sql_schema->{ $table } );
233     }
234 dpavlin 19 }
235 dpavlin 5
236 dpavlin 50
237     =head2 meta
238    
239     Set or get some meta data into database
240    
241     meta('nick','channel','var_name', $var_value );
242    
243     $var_value = meta('nick','channel','var_name');
244     ( $var_value, $changed ) = meta('nick','channel','var_name');
245    
246     =cut
247    
248     sub meta {
249     my ($nick,$channel,$name,$value) = @_;
250    
251     # normalize channel name
252     $channel =~ s/^#//;
253    
254     if (defined($value)) {
255    
256     my $sth = $dbh->prepare(qq{ update meta set value = ?, changed = now() where nick = ? and channel = ? and name = ? });
257    
258     eval { $sth->execute( $value, $nick, $channel, $name ) };
259    
260 dpavlin 140 if ( $@ ) {
261     # error
262     _log("META ERROR: $@");
263     } elsif ( ! $sth->rows ) {
264     # no result -> add new
265 dpavlin 50 $sth = $dbh->prepare(qq{ insert into meta (value,nick,channel,name,changed) values (?,?,?,?,now()) });
266 dpavlin 140 eval { $sth->execute( $value, $nick, $channel, $name ); };
267     if ( $@ ) {
268     _log "META ERROR: $@";
269     } else {
270     _log "META: created $nick/$channel/$name = $value\n";
271     }
272 dpavlin 50 } else {
273 dpavlin 140 _log "META: updated $nick/$channel/$name = $value\n";
274 dpavlin 50 }
275    
276     return $value;
277    
278     } else {
279    
280     my $sth = $dbh->prepare(qq{ select value,changed from meta where nick = ? and channel = ? and name = ? });
281     $sth->execute( $nick, $channel, $name );
282     my ($v,$c) = $sth->fetchrow_array;
283 dpavlin 95 warn "## fetched $nick/$channel/$name = $v [$c]\n";
284 dpavlin 50 return ($v,$c) if wantarray;
285     return $v;
286    
287     }
288     }
289    
290    
291    
292 dpavlin 87 my $sth_insert_log = $dbh->prepare(qq{
293 dpavlin 5 insert into log
294 dpavlin 37 (channel, me, nick, message, time)
295     values (?,?,?,?,?)
296 dpavlin 5 });
297    
298 dpavlin 50
299 dpavlin 28 my $tags;
300    
301 dpavlin 11 =head2 get_from_log
302 dpavlin 5
303 dpavlin 11 my @messages = get_from_log(
304     limit => 42,
305     search => '%what to stuff in ilike%',
306 dpavlin 13 fmt => {
307     time => '{%s} ',
308     time_channel => '{%s %s} ',
309     nick => '%s: ',
310 dpavlin 20 me_nick => '***%s ',
311 dpavlin 13 message => '%s',
312     },
313 dpavlin 20 filter => {
314     message => sub {
315     # modify message content
316     return shift;
317     }
318 dpavlin 21 },
319     context => 5,
320 dpavlin 42 full_rows => 1,
321 dpavlin 11 );
322    
323 dpavlin 20 Order is important. Fields are first passed through C<filter> (if available) and
324     then throgh C<< sprintf($fmt->{message}, $message >> if available.
325    
326 dpavlin 21 C<context> defines number of messages around each search hit for display.
327    
328 dpavlin 42 C<full_rows> will return database rows for each result with C<date>, C<time>, C<channel>,
329     C<me>, C<nick> and C<message> keys.
330    
331 dpavlin 11 =cut
332    
333     sub get_from_log {
334     my $args = {@_};
335    
336 dpavlin 68 if ( ! $args->{fmt} ) {
337     $args->{fmt} = {
338     date => '[%s] ',
339     time => '{%s} ',
340     time_channel => '{%s %s} ',
341     nick => '%s: ',
342     me_nick => '***%s ',
343     message => '%s',
344     };
345     }
346 dpavlin 13
347 dpavlin 21 my $sql_message = qq{
348 dpavlin 11 select
349     time::date as date,
350     time::time as time,
351     channel,
352 dpavlin 20 me,
353 dpavlin 11 nick,
354     message
355     from log
356     };
357 dpavlin 21
358     my $sql_context = qq{
359     select
360     id
361     from log
362     };
363    
364     my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
365    
366     my $sql = $context ? $sql_context : $sql_message;
367    
368 dpavlin 67 sub check_date {
369 dpavlin 68 my $date = shift || return;
370     my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
371 dpavlin 64 if ( $@ ) {
372 dpavlin 68 warn "invalid date $date\n";
373     $new_date = DateTime->now->ymd;
374 dpavlin 64 }
375 dpavlin 68 return $new_date;
376 dpavlin 67 }
377    
378 dpavlin 68 my @where;
379     my @args;
380 dpavlin 100 my $msg;
381 dpavlin 68
382     if (my $search = $args->{search}) {
383     $search =~ s/^\s+//;
384     $search =~ s/\s+$//;
385     push @where, 'message ilike ? or nick ilike ?';
386     push @args, ( ( '%' . $search . '%' ) x 2 );
387 dpavlin 100 $msg = "Search for '$search'";
388 dpavlin 63 }
389 dpavlin 68
390     if ($args->{tag} && $tags->{ $args->{tag} }) {
391     push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
392 dpavlin 100 $msg = "Search for tags $args->{tag}";
393 dpavlin 68 }
394    
395     if (my $date = $args->{date} ) {
396     $date = check_date( $date );
397     push @where, 'date(time) = ?';
398     push @args, $date;
399 dpavlin 100 $msg = "search for date $date";
400 dpavlin 68 }
401    
402     $sql .= " where " . join(" and ", @where) if @where;
403    
404 dpavlin 11 $sql .= " order by log.time desc";
405 dpavlin 35 $sql .= " limit " . $args->{limit} if ($args->{limit});
406 dpavlin 11
407 dpavlin 68 #warn "### sql: $sql ", dump( @args );
408    
409 dpavlin 11 my $sth = $dbh->prepare( $sql );
410 dpavlin 69 eval { $sth->execute( @args ) };
411     return if $@;
412 dpavlin 68
413 dpavlin 100 my $nr_results = $sth->rows;
414    
415 dpavlin 11 my $last_row = {
416     date => '',
417     time => '',
418     channel => '',
419     nick => '',
420     };
421    
422     my @rows;
423    
424     while (my $row = $sth->fetchrow_hashref) {
425     unshift @rows, $row;
426     }
427    
428 dpavlin 42 # normalize nick names
429     map {
430     $_->{nick} =~ s/^_*(.*?)_*$/$1/
431     } @rows;
432    
433     return @rows if ($args->{full_rows});
434    
435 dpavlin 100 $msg .= ' produced ' . (
436     $nr_results == 0 ? 'no results' :
437     $nr_results == 0 ? 'one result' :
438     $nr_results . ' results'
439 dpavlin 16 );
440 dpavlin 11
441 dpavlin 100 my @msgs = ( $msg );
442    
443 dpavlin 21 if ($context) {
444     my @ids = @rows;
445     @rows = ();
446    
447     my $last_to = 0;
448    
449     my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
450     foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
451     my $id = $row_id->{id} || die "can't find id in row";
452    
453     my ($from, $to) = ($id - $context, $id + $context);
454     $from = $last_to if ($from < $last_to);
455     $last_to = $to;
456     $sth->execute( $from, $to );
457    
458     #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
459    
460     while (my $row = $sth->fetchrow_hashref) {
461     push @rows, $row;
462     }
463    
464     }
465     }
466    
467 dpavlin 35 # sprintf which can take coderef as first parametar
468     sub cr_sprintf {
469     my $fmt = shift || return;
470     if (ref($fmt) eq 'CODE') {
471     $fmt->(@_);
472     } else {
473     sprintf($fmt, @_);
474     }
475     }
476    
477 dpavlin 11 foreach my $row (@rows) {
478    
479     $row->{time} =~ s#\.\d+##;
480    
481     my $msg = '';
482    
483 dpavlin 35 $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
484 dpavlin 26 my $t = $row->{time};
485    
486 dpavlin 13 if ($last_row->{channel} ne $row->{channel}) {
487 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
488 dpavlin 13 } else {
489 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{time}, $t);
490 dpavlin 13 }
491 dpavlin 11
492 dpavlin 12 my $append = 1;
493 dpavlin 11
494 dpavlin 22 my $nick = $row->{nick};
495 dpavlin 42 # if ($nick =~ s/^_*(.*?)_*$/$1/) {
496     # $row->{nick} = $nick;
497     # }
498 dpavlin 24
499 dpavlin 105 $append = 0 if $row->{me};
500    
501 dpavlin 22 if ($last_row->{nick} ne $nick) {
502 dpavlin 20 # obfu way to find format for me_nick if needed or fallback to default
503     my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
504     $fmt ||= '%s';
505    
506     $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
507    
508 dpavlin 35 $msg .= cr_sprintf( $fmt, $nick );
509 dpavlin 12 $append = 0;
510     }
511    
512 dpavlin 20 $args->{fmt}->{message} ||= '%s';
513     if (ref($args->{filter}->{message}) eq 'CODE') {
514 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{message},
515 dpavlin 20 $args->{filter}->{message}->(
516 dpavlin 15 $row->{message}
517     )
518     );
519     } else {
520 dpavlin 35 $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
521 dpavlin 15 }
522 dpavlin 11
523 dpavlin 12 if ($append && @msgs) {
524     $msgs[$#msgs] .= " " . $msg;
525     } else {
526     push @msgs, $msg;
527     }
528 dpavlin 11
529     $last_row = $row;
530     }
531    
532     return @msgs;
533     }
534    
535 dpavlin 37 # tags support
536 dpavlin 11
537 dpavlin 133 my $cloud = TagCloud->new;
538     $cloud->seed_tags;
539 dpavlin 4
540 dpavlin 36 =head2 save_message
541    
542 dpavlin 37 save_message(
543     channel => '#foobar',
544     me => 0,
545     nick => 'dpavlin',
546 dpavlin 70 message => 'test message',
547 dpavlin 37 time => '2006-06-25 18:57:18',
548     );
549 dpavlin 36
550 dpavlin 37 C<time> is optional, it will use C<< now() >> if it's not available.
551    
552     C<me> if not specified will be C<0> (not C</me> message)
553    
554 dpavlin 36 =cut
555    
556     sub save_message {
557 dpavlin 37 my $a = {@_};
558 dpavlin 70 confess "have msg" if $a->{msg};
559 dpavlin 37 $a->{me} ||= 0;
560 dpavlin 38 $a->{time} ||= strftime($TIMESTAMP,localtime());
561 dpavlin 37
562 dpavlin 125 _log "ARCHIVE",
563 dpavlin 37 $a->{channel}, " ",
564     $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
565 dpavlin 70 " " . $a->{message};
566 dpavlin 37
567 dpavlin 132 eval { $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time}); };
568 dpavlin 147
569     eval {
570     my @channel = ( 'channel' , $a->{channel}, $a->{nick} );
571     push @channel, 'me' if $a->{me};
572 dpavlin 149 # my $redis = Redis->new( server => '192.168.1.61:6379' );
573     # $redis->publish( join(' ',@channel), $a->{message} );
574 dpavlin 147 };
575    
576 dpavlin 140 if ( $@ ) {
577     _log "ERROR: can't archive ", $a->{message};
578     } else {
579     $cloud->add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
580     }
581 dpavlin 36 }
582    
583 dpavlin 50
584 dpavlin 37 if ($import_dircproxy) {
585 dpavlin 150 my ( $from_time, $date_time ) = $dbh->selectrow_array(qq{
586     select date_part('epoch',max(time)),max(time) from log
587     });
588    
589     warn "IMPORT $date_time [$from_time]\n";
590    
591 dpavlin 37 open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
592     warn "importing $import_dircproxy...\n";
593 dpavlin 69 my $tz_offset = 1 * 60 * 60; # TZ GMT+2
594 dpavlin 37 while(<$l>) {
595     chomp;
596     if (/^@(\d+)\s(\S+)\s(.+)$/) {
597     my ($time, $nick, $msg) = ($1,$2,$3);
598    
599 dpavlin 150 next if $time <= $from_time;
600    
601 dpavlin 37 my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
602    
603     my $me = 0;
604     $me = 1 if ($nick =~ m/^\[\S+]/);
605     $nick =~ s/^[\[<]([^!]+).*$/$1/;
606    
607     $msg =~ s/^ACTION\s+// if ($me);
608    
609     save_message(
610     channel => $CHANNEL,
611     me => $me,
612     nick => $nick,
613 dpavlin 70 message => $msg,
614 dpavlin 37 time => $dt->ymd . " " . $dt->hms,
615     ) if ($nick !~ m/^-/);
616    
617     } else {
618 dpavlin 45 _log "can't parse: $_";
619 dpavlin 37 }
620     }
621     close($l);
622     warn "import over\n";
623     exit;
624     }
625    
626 dpavlin 85 #
627     # RSS follow
628     #
629 dpavlin 37
630 dpavlin 108 my $_stat;
631 dpavlin 85
632 dpavlin 122 POE::Component::Client::HTTP->spawn(
633     Alias => 'rss-fetch',
634     Timeout => 30,
635     );
636 dpavlin 85
637 dpavlin 125 =head2 rss_parse_xml
638    
639     rss_parse_xml({
640     url => 'http://www.example.com/rss',
641     send_rss_msgs => 42,
642     });
643    
644     =cut
645    
646 dpavlin 122 sub rss_parse_xml {
647 dpavlin 126 my ($kernel,$args) = @_;
648 dpavlin 85
649 dpavlin 131 warn "## rss_parse_xml ",dump( $args ) if $debug;
650 dpavlin 122
651 dpavlin 85 # how many messages to send out when feed is seen for the first time?
652 dpavlin 125 my $send_rss_msgs = $args->{send_rss_msgs};
653     $send_rss_msgs = 1 if ! defined $send_rss_msgs;
654 dpavlin 85
655 dpavlin 126 warn "## RSS fetch first $send_rss_msgs items from", $args->{url} if $debug;
656 dpavlin 87
657 dpavlin 140 my $feed;
658     eval { $feed = XML::Feed->parse( \$args->{xml} ) };
659 dpavlin 85 if ( ! $feed ) {
660 dpavlin 122 _log "can't fetch RSS ", $args->{url}, XML::Feed->errstr;
661 dpavlin 85 return;
662     }
663 dpavlin 92
664 dpavlin 117 $_stat->{rss}->{url2link}->{ $args->{url} } = $feed->link;
665    
666 dpavlin 87 my ( $total, $updates ) = ( 0, 0 );
667 dpavlin 85 for my $entry ($feed->entries) {
668 dpavlin 87 $total++;
669 dpavlin 85
670 dpavlin 120 my $seen_times = $_stat->{rss}->{seen}->{$args->{channel}}->{$feed->link}->{$entry->id}++;
671 dpavlin 85 # seen allready?
672 dpavlin 122 warn "## $seen_times ",$entry->id if $debug;
673 dpavlin 120 next if $seen_times > 0;
674 dpavlin 85
675     sub prefix {
676     my ($txt,$var) = @_;
677 dpavlin 93 $var =~ s/\s+/ /gs;
678 dpavlin 85 $var =~ s/^\s+//g;
679 dpavlin 93 $var =~ s/\s+$//g;
680 dpavlin 85 return $txt . $var if $var;
681     }
682    
683 dpavlin 94 # 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 dpavlin 85 my $msg;
694 dpavlin 90 $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
695 dpavlin 85 $msg .= prefix( ' by ' , $entry->author );
696 dpavlin 92 $msg .= prefix( ' | ' , $entry->title );
697 dpavlin 94 $msg .= prefix( ' | ' , $link );
698 dpavlin 85 # $msg .= prefix( ' id ' , $entry->id );
699 dpavlin 131 my @categories = $entry->category;
700     warn "## category = ", dump( @categories ) if $debug;
701 dpavlin 114 if ( my $tags = $entry->category ) {
702 dpavlin 131 $tags = join(' ', @$tags) if ref($tags) eq 'ARRAY';
703 dpavlin 114 $tags =~ s!^\s+!!;
704     $tags =~ s!\s*$! !;
705 dpavlin 118 $tags =~ s!,?\s+!// !g;
706 dpavlin 114 $msg .= prefix( ' ' , $tags );
707     }
708 dpavlin 85
709 dpavlin 120 if ( $seen_times == 0 && $send_rss_msgs ) {
710 dpavlin 85 $send_rss_msgs--;
711 dpavlin 106 if ( ! $args->{private} ) {
712     # FIXME bug! should be save_message
713 dpavlin 119 save_message( channel => $args->{channel}, me => 1, nick => $NICK, message => $msg );
714     # $sth_insert_log->execute( $args->{channel}, 1, $NICK, $msg, 'now()' );
715 dpavlin 106 }
716 dpavlin 97 my ( $type, $to ) = ( 'notice', $args->{channel} );
717     ( $type, $to ) = ( 'privmsg', $args->{nick} ) if $args->{private};
718 dpavlin 119
719 dpavlin 126 _log(">> RSS $type to $to:", $msg);
720     $kernel->post( $irc => $type => $to => $msg );
721 dpavlin 119
722 dpavlin 85 $updates++;
723     }
724     }
725    
726     my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
727     $sql .= qq{, updates = updates + $updates } if $updates;
728     $sql .= qq{where id = } . $args->{id};
729 dpavlin 86 eval { $dbh->do( $sql ) };
730 dpavlin 85
731 dpavlin 126 _log "RSS $updates/$total new items from", $args->{url};
732 dpavlin 87
733 dpavlin 85 return $updates;
734     }
735    
736     sub rss_fetch_all {
737 dpavlin 125 my ( $kernel, $send_rss_msgs ) = @_;
738     warn "## rss_fetch_all -- send_rss_msgs: $send_rss_msgs\n" if $debug;
739 dpavlin 85 my $sql = qq{
740 dpavlin 97 select id, url, name, channel, nick, private
741 dpavlin 85 from feeds
742     where active is true
743     };
744     # limit to newer feeds only if we are not sending messages out
745 dpavlin 122 $sql .= qq{ and last_update + delay < now() } if defined ( $_stat->{rss}->{fetch} );
746 dpavlin 85 my $sth = $dbh->prepare( $sql );
747     $sth->execute();
748     warn "# ",$sth->rows," active RSS feeds\n";
749     my $count = 0;
750     while (my $row = $sth->fetchrow_hashref) {
751 dpavlin 125 $row->{send_rss_msgs} = $send_rss_msgs if defined $send_rss_msgs;
752 dpavlin 122 $_stat->{rss}->{fetch}->{ $row->{url} } = $row;
753     $kernel->post(
754     'rss-fetch',
755     'request',
756     'rss_response',
757     HTTP::Request->new( GET => $row->{url} ),
758     );
759 dpavlin 125 warn "## queued rss-fetch ", dump( $row ) if $debug;
760 dpavlin 85 }
761 dpavlin 122 return "OK, scheduled " . $sth->rows . " feeds for refresh";
762 dpavlin 85 }
763    
764    
765     sub rss_check_updates {
766     my $kernel = shift;
767 dpavlin 108 $_stat->{rss}->{last_poll} ||= time();
768     my $dt = time() - $_stat->{rss}->{last_poll};
769 dpavlin 95 if ( $dt > $rss_min_delay ) {
770 dpavlin 119 warn "## rss_check_updates $dt > $rss_min_delay\n";
771 dpavlin 108 $_stat->{rss}->{last_poll} = time();
772 dpavlin 85 _log rss_fetch_all( $kernel );
773     }
774     }
775    
776 dpavlin 131 sub process_command {
777     my ( $kernel, $nick, $channel, $msg ) = @_;
778    
779     my $res = "unknown command '$msg', try /msg $NICK help!";
780    
781     if ($msg =~ m/^help/i) {
782    
783     $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
784    
785     } elsif ($msg =~ m/^(privmsg|notice)\s+(\S+)\s+(.*)$/i) {
786    
787     _log ">> /$1 $2 $3";
788     $kernel->post( $irc => $1 => $2, $3 );
789     $res = '';
790    
791     } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
792    
793     my $nr = $1 || 10;
794    
795     my $sth = $dbh->prepare(qq{
796     select
797     trim(both '_' from nick) as nick,
798     count(*) as count,
799     sum(length(message)) as len
800     from log
801     group by trim(both '_' from nick)
802     order by len desc,count desc
803     limit $nr
804     });
805     $sth->execute();
806     $res = "Top $nr users: ";
807     my @users;
808     while (my $row = $sth->fetchrow_hashref) {
809     push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
810     }
811     $res .= join(" | ", @users);
812     } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
813    
814     my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
815    
816     foreach my $res (get_from_log( limit => $limit )) {
817     _log "last: $res";
818     $kernel->post( $irc => privmsg => $nick, $res );
819     }
820    
821     $res = '';
822    
823     } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
824    
825     my $what = $2;
826    
827     foreach my $res (get_from_log(
828     limit => 20,
829     search => $what,
830     )) {
831     _log "search [$what]: $res";
832     $kernel->post( $irc => privmsg => $nick, $res );
833     }
834    
835     $res = '';
836    
837     } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
838    
839     my ($what,$limit) = ($1,$2);
840     $limit ||= 100;
841    
842     my $stat;
843    
844     foreach my $res (get_from_log(
845     limit => $limit,
846     search => $what,
847     full_rows => 1,
848     )) {
849     while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
850     $stat->{vote}->{$1}++;
851     $stat->{from}->{ $res->{nick} }++;
852     }
853     }
854    
855     my @nicks;
856     foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
857     push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
858     "(" . $stat->{from}->{$nick} . ")"
859     );
860     }
861    
862     $res =
863     "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
864     " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
865     " from " . ( join(", ", @nicks) || 'nobody' );
866    
867     $kernel->post( $irc => notice => $nick, $res );
868    
869     } elsif ($msg =~ m/^ping/) {
870     $res = "ping = " . dump( $_stat->{ping} );
871     } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
872     if ( ! defined( $1 ) ) {
873     my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
874     $sth->execute( $nick, $channel );
875     $res = "config for $nick on $channel";
876     while ( my ($n,$v) = $sth->fetchrow_array ) {
877     $res .= " | $n = $v";
878     }
879     } elsif ( ! $2 ) {
880     my $val = meta( $nick, $channel, $1 );
881     $res = "current $1 = " . ( $val ? $val : 'undefined' );
882     } else {
883     my $validate = {
884     'last-size' => qr/^\d+/,
885     'twitter' => qr/^\w+\s+\w+/,
886     };
887    
888     my ( $op, $val ) = ( $1, $2 );
889    
890     if ( my $regex = $validate->{$op} ) {
891     if ( $val =~ $regex ) {
892     meta( $nick, $channel, $op, $val );
893     $res = "saved $op = $val";
894     } else {
895     $res = "config option $op = $val doesn't validate against $regex";
896     }
897     } else {
898     $res = "config option $op doesn't exist";
899     }
900     }
901     } elsif ($msg =~ m/^rss-update/) {
902     $res = rss_fetch_all( $kernel );
903     } elsif ($msg =~ m/^rss-list/) {
904     my $sth = $dbh->prepare(qq{ select url,name,last_update,active,channel,nick,private from feeds });
905     $sth->execute;
906     while (my @row = $sth->fetchrow_array) {
907     $kernel->post( $irc => privmsg => $nick, join(' | ',@row) );
908     }
909     $res = '';
910     } elsif ($msg =~ m!^rss-(add|remove|stop|start|clean)(?:-(private))?\s+(http://\S+)\s*(.*)!) {
911     my ( $command, $sub, $url, $arg ) = ( $1,$2,$3,$4 );
912    
913     my $channel = $1 if ( $arg =~ s/\s*(#\S+)\s*// );
914     $channel = $nick if $sub eq 'private';
915    
916     my $sql = {
917     add => qq{ insert into feeds (url,name,channel,nick,private) values (?,?,?,?,?) },
918     remove => qq{ delete from feeds where url = ? and nick = ? },
919     start => qq{ update feeds set active = true where url = ? },
920     stop => qq{ update feeds set active = false where url = ? },
921     clean => qq{ update feeds set last_update = now() - delay where url = ? },
922     };
923    
924     if ( $command eq 'add' && ! $channel ) {
925     $res = "ERROR: got '$msg' which doesn't have #channel in it, ignoring!";
926     } elsif (my $q = $sql->{$command} ) {
927     my $sth = $dbh->prepare( $q );
928     my @data = ( $url );
929     if ( $command eq 'add' ) {
930     push @data, ( $arg, $channel, $nick, $sub eq 'private' ? 1 : 0 );
931     } elsif ( $command eq 'remove' ) {
932     push @data, $nick;
933     }
934     warn "## $command SQL $q with ",dump( @data ),"\n";
935     eval { $sth->execute( @data ) };
936     if ($@) {
937     $res = "ERROR: $@";
938     } else {
939     $res = "OK, RSS executed $command" .
940     ( $sub ? "-$sub " : ' ' ) .
941     ( $channel ? "on $channel " : '' ) .
942     "url $url";
943     if ( $command eq 'clean' ) {
944     my $seen = $_stat->{rss}->{seen} || die "no seen?";
945     my $want_link = $_stat->{rss}->{url2link}->{$url} || warn "no url2link($url)";
946     foreach my $c ( keys %$seen ) {
947     my $c_hash = $seen->{$c} || die "no seen->{$c}";
948     die "not HASH with rss links but ", dump($c_hash) unless ref($c_hash) eq 'HASH';
949     foreach my $link ( keys %$c_hash ) {
950     next unless $link eq $want_link;
951     _log "RSS removed seen $c $url $link";
952     }
953     }
954     } elsif ( $command eq 'add' ) {
955     rss_fetch_all( $kernel );
956     }
957     }
958     } else {
959     $res = "ERROR: don't know what to do with: $msg";
960     }
961     } elsif ($msg =~ m/^rss-clean/) {
962     # this makes sense because we didn't catch rss-clean http://... before!
963     $_stat->{rss} = undef;
964     $dbh->do( qq{ update feeds set last_update = now() - delay } );
965     $res = rss_fetch_all( $kernel );
966     }
967    
968     return $res;
969     }
970    
971 dpavlin 85 POE::Session->create( inline_states => {
972     _start => sub {
973 dpavlin 109 $_[KERNEL]->post( $irc => register => 'all' );
974     $_[KERNEL]->post( $irc => connect => {} );
975 dpavlin 4 },
976 dpavlin 109 irc_001 => sub {
977     my ($kernel,$sender) = @_[KERNEL,SENDER];
978     my $poco_object = $sender->get_heap();
979     _log "connected to",$poco_object->server_name();
980     $kernel->post( $sender => join => $_ ) for @channels;
981 dpavlin 125 # seen RSS cache, so don't send out messages
982     _log rss_fetch_all( $kernel, 0 );
983 dpavlin 109 undef;
984     },
985 dpavlin 122 # irc_255 => sub { # server is done blabbing
986     # $_[KERNEL]->post( $irc => join => $CHANNEL);
987     # },
988 dpavlin 4 irc_public => sub {
989 dpavlin 7 my $kernel = $_[KERNEL];
990     my $nick = (split /!/, $_[ARG0])[0];
991     my $channel = $_[ARG1]->[0];
992     my $msg = $_[ARG2];
993 dpavlin 4
994 dpavlin 70 save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
995 dpavlin 50 meta( $nick, $channel, 'last-msg', $msg );
996 dpavlin 95 rss_check_updates( $kernel );
997 dpavlin 4 },
998 dpavlin 19 irc_ctcp_action => sub {
999     my $kernel = $_[KERNEL];
1000     my $nick = (split /!/, $_[ARG0])[0];
1001     my $channel = $_[ARG1]->[0];
1002     my $msg = $_[ARG2];
1003    
1004 dpavlin 70 save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
1005 dpavlin 50
1006 dpavlin 54 if ( $use_twitter ) {
1007 dpavlin 58 if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
1008 dpavlin 54 my ($login,$passwd) = split(/\s+/,$twitter,2);
1009     _log("sending twitter for $nick/$login on $channel ");
1010     my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
1011     $bot->update("<${channel}> $msg");
1012     }
1013 dpavlin 50 }
1014    
1015 dpavlin 19 },
1016 dpavlin 43 irc_ping => sub {
1017 dpavlin 84 _log( "pong ", $_[ARG0] );
1018 dpavlin 109 $_stat->{ping}->{ $_[ARG0] }++;
1019 dpavlin 85 rss_check_updates( $_[KERNEL] );
1020 dpavlin 43 },
1021     irc_invite => sub {
1022     my $kernel = $_[KERNEL];
1023     my $nick = (split /!/, $_[ARG0])[0];
1024     my $channel = $_[ARG1];
1025    
1026 dpavlin 85 _log "invited to $channel by $nick";
1027 dpavlin 43
1028 dpavlin 109 $_[KERNEL]->post( $irc => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
1029     $_[KERNEL]->post( $irc => 'join' => $channel );
1030 dpavlin 43
1031     },
1032 dpavlin 7 irc_msg => sub {
1033     my $kernel = $_[KERNEL];
1034     my $nick = (split /!/, $_[ARG0])[0];
1035 dpavlin 131 my $channel = $_[ARG1]->[0];
1036 dpavlin 7 my $msg = $_[ARG2];
1037 dpavlin 119 warn "# ARG = ",dump( @_[ARG0,ARG1,ARG2] ) if $debug;
1038 dpavlin 7
1039 dpavlin 45 _log "<< $msg";
1040 dpavlin 7
1041 dpavlin 131 my $res = process_command( $_[KERNEL], $nick, $channel, $msg );
1042 dpavlin 7
1043 dpavlin 8 if ($res) {
1044 dpavlin 45 _log ">> [$nick] $res";
1045 dpavlin 109 $_[KERNEL]->post( $irc => privmsg => $nick, $res );
1046 dpavlin 8 }
1047 dpavlin 7
1048 dpavlin 85 rss_check_updates( $_[KERNEL] );
1049 dpavlin 7 },
1050 dpavlin 107 irc_372 => sub {
1051     _log "<< motd",$_[ARG0],$_[ARG1];
1052     },
1053     irc_375 => sub {
1054     _log "<< motd", $_[ARG0], "start";
1055     },
1056     irc_376 => sub {
1057     _log "<< motd", $_[ARG0], "end";
1058     },
1059 dpavlin 114 # irc_433 => sub {
1060     # print "# irc_433: ",$_[ARG1], "\n";
1061     # warn "## indetify $NICK\n";
1062     # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1063     # },
1064     # irc_451 # please register
1065 dpavlin 10 irc_477 => sub {
1066 dpavlin 103 _log "<< irc_477: ",$_[ARG1];
1067 dpavlin 114 _log ">> IDENTIFY $NICK";
1068     $_[KERNEL]->post( $irc => privmsg => 'NickServ', "IDENTIFY $NICK" );
1069 dpavlin 10 },
1070 dpavlin 7 irc_505 => sub {
1071 dpavlin 103 _log "<< irc_505: ",$_[ARG1];
1072 dpavlin 114 _log ">> register $NICK";
1073     $_[KERNEL]->post( $irc => privmsg => 'NickServ', "register $NICK" );
1074     # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1075 dpavlin 109 # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set hide email on" );
1076     # $_[KERNEL]->post( $irc => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
1077 dpavlin 8 },
1078     irc_registered => sub {
1079 dpavlin 109 _log "<< registered $NICK";
1080 dpavlin 10 },
1081 dpavlin 41 irc_disconnected => sub {
1082 dpavlin 103 _log "## disconnected.. sleeping for $sleep_on_error seconds and reconnecting again";
1083     sleep($sleep_on_error);
1084 dpavlin 109 $_[KERNEL]->post( $irc => connect => {} );
1085 dpavlin 41 },
1086     irc_socketerr => sub {
1087 dpavlin 45 _log "## socket error... sleeping for $sleep_on_error seconds and retry";
1088 dpavlin 41 sleep($sleep_on_error);
1089 dpavlin 109 $_[KERNEL]->post( $irc => connect => {} );
1090 dpavlin 41 },
1091 dpavlin 109 irc_notice => sub {
1092 dpavlin 116 _log "<< notice from ", $_[ARG0], $_[ARG1], $_[ARG2];
1093     my $m = $_[ARG2];
1094     if ( $m =~ m!/msg.*(NickServ).*(IDENTIFY)!i ) {
1095     _log ">> suggested to $1 $2";
1096     $_[KERNEL]->post( $irc => privmsg => $1, "$2 $NICK" );
1097     } elsif ( $m =~ m!\Q$NICK\E.*registered!i ) {
1098     _log ">> registreted, so IDENTIFY";
1099 dpavlin 109 $_[KERNEL]->post( $irc => privmsg => 'nickserv', "IDENTIFY $NICK" );
1100 dpavlin 116 } else {
1101 dpavlin 119 warn "## ignore $m\n" if $debug;
1102 dpavlin 109 }
1103     },
1104 dpavlin 103 irc_snotice => sub {
1105 dpavlin 116 _log "<< snotice", $_[ARG0]; #dump( $_[ARG0],$_[ARG1], $_[ARG2] );
1106 dpavlin 103 if ( $_[ARG0] =~ m!/(QUOTE)\s+(PASS\s+\d+)!i ) {
1107     warn ">> $1 | $2\n";
1108 dpavlin 109 $_[KERNEL]->post( $irc => lc($1) => $2);
1109 dpavlin 103 }
1110     },
1111 dpavlin 4 _child => sub {},
1112     _default => sub {
1113 dpavlin 131 _log '_default SID:', $_[SESSION]->ID, $_[ARG0], dump( $_[ARG1] );
1114     0; # false for signals
1115 dpavlin 4 },
1116 dpavlin 122 rss_response => sub {
1117     my ($request_packet, $response_packet) = @_[ARG0, ARG1];
1118     my $request_object = $request_packet->[0];
1119     my $response_object = $response_packet->[0];
1120    
1121     my $row = delete( $_stat->{rss}->{fetch}->{ $request_object->uri } );
1122     if ( $row ) {
1123     $row->{xml} = $response_object->content;
1124 dpavlin 126 rss_parse_xml( $_[KERNEL], $row );
1125 dpavlin 122 } else {
1126     warn "## can't find rss->fetch for ", $request_object->uri;
1127     }
1128     },
1129 dpavlin 4 },
1130     );
1131    
1132 dpavlin 13 # http server
1133    
1134 dpavlin 114 _log "WEB archive at $url";
1135    
1136 dpavlin 13 my $httpd = POE::Component::Server::HTTP->new(
1137 dpavlin 70 Port => $http_port,
1138 dpavlin 83 PreHandler => {
1139     '/' => sub {
1140     $_[0]->header(Connection => 'close')
1141     }
1142     },
1143 dpavlin 13 ContentHandler => { '/' => \&root_handler },
1144     Headers => { Server => 'irc-logger' },
1145     );
1146    
1147     my $style = <<'_END_OF_STYLE_';
1148 dpavlin 16 p { margin: 0; padding: 0.1em; }
1149 dpavlin 13 .time, .channel { color: #808080; font-size: 60%; }
1150 dpavlin 28 .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1151 dpavlin 20 .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1152 dpavlin 13 .message { color: #000000; font-size: 100%; }
1153 dpavlin 16 .search { float: right; }
1154 dpavlin 60 a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1155     a:hover.tag { border: 1px solid #eee }
1156     hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1157     /*
1158 dpavlin 20 .col-0 { background: #ffff66 }
1159     .col-1 { background: #a0ffff }
1160     .col-2 { background: #99ff99 }
1161     .col-3 { background: #ff9999 }
1162     .col-4 { background: #ff66ff }
1163 dpavlin 60 */
1164 dpavlin 65 .calendar { border: 1px solid red; width: 100%; }
1165     .month { border: 0px; width: 100%; }
1166 dpavlin 13 _END_OF_STYLE_
1167    
1168 dpavlin 70 $max_color = 0;
1169 dpavlin 20
1170 dpavlin 60 my @cols = qw(
1171     #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1172     #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1173     #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1174     #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1175     #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1176     );
1177    
1178     foreach my $c (@cols) {
1179     $style .= ".col-${max_color} { background: $c }\n";
1180     $max_color++;
1181     }
1182 dpavlin 114 _log "WEB defined $max_color colors for users...";
1183 dpavlin 60
1184 dpavlin 13 sub root_handler {
1185     my ($request, $response) = @_;
1186     $response->code(RC_OK);
1187 dpavlin 16
1188 dpavlin 83 # this doesn't seem to work, so moved to PreHandler
1189     #$response->header(Connection => 'close');
1190    
1191 dpavlin 73 return RC_OK if $request->uri =~ m/favicon.ico$/;
1192    
1193 dpavlin 143 if ( $request->uri =~ m/robots.txt$/ ) {
1194     $response->content_type( 'text/plain' );
1195     $response->content( qq{
1196    
1197     User-Agent: *
1198 dpavlin 144 Disallow: /
1199 dpavlin 143
1200     });
1201     return RC_OK;
1202     }
1203    
1204 dpavlin 16 my $q;
1205    
1206     if ( $request->method eq 'POST' ) {
1207     $q = new CGI::Simple( $request->content );
1208     } elsif ( $request->uri =~ /\?(.+)$/ ) {
1209     $q = new CGI::Simple( $1 );
1210     } else {
1211     $q = new CGI::Simple;
1212     }
1213    
1214     my $search = $q->param('search') || $q->param('grep') || '';
1215 dpavlin 108 my $r_url = $request->url;
1216 dpavlin 16
1217 dpavlin 108 my @commands = qw( tags last-tag follow stat );
1218     my $commands_re = join('|',@commands);
1219    
1220     if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1221 dpavlin 77 my $show = lc($1);
1222 dpavlin 79 my $nr = $2;
1223 dpavlin 77
1224 dpavlin 71 my $type = 'RSS'; # Atom
1225 dpavlin 70
1226 dpavlin 72 $response->content_type( 'application/' . lc($type) . '+xml' );
1227 dpavlin 70
1228     my $html = '<!-- error -->';
1229 dpavlin 133 #warn "create $type feed from ",dump( $cloud->last_tags );
1230 dpavlin 70
1231     my $feed = XML::Feed->new( $type );
1232 dpavlin 85 $feed->link( $url );
1233 dpavlin 70
1234 dpavlin 108 my $rc = RC_OK;
1235    
1236 dpavlin 77 if ( $show eq 'tags' ) {
1237 dpavlin 79 $nr ||= 50;
1238 dpavlin 77 $feed->title( "tags from $CHANNEL" );
1239     $feed->link( "$url/tags" );
1240     $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1241 dpavlin 70 my $feed_entry = XML::Feed::Entry->new($type);
1242 dpavlin 79 $feed_entry->title( "$nr tags from $CHANNEL" );
1243 dpavlin 77 $feed_entry->author( $NICK );
1244     $feed_entry->link( '/#tags' );
1245 dpavlin 75
1246 dpavlin 73 $feed_entry->content(
1247 dpavlin 77 qq{<![CDATA[<style type="text/css">}
1248     . $cloud->css
1249     . qq{</style>}
1250 dpavlin 79 . $cloud->html( $nr )
1251 dpavlin 77 . qq{]]>}
1252 dpavlin 70 );
1253     $feed->add_entry( $feed_entry );
1254 dpavlin 77
1255 dpavlin 79 } elsif ( $show eq 'last-tag' ) {
1256 dpavlin 77
1257 dpavlin 79 $nr ||= $last_x_tags;
1258 dpavlin 80 $nr = $last_x_tags if $nr > $last_x_tags;
1259 dpavlin 79
1260     $feed->title( "last $nr tagged messages from $CHANNEL" );
1261 dpavlin 77 $feed->description( "collects messages which have tags// in them" );
1262    
1263 dpavlin 133 foreach my $m ( $cloud->last_tags ) {
1264 dpavlin 77 # warn dump( $m );
1265     #my $tags = join(' ', @{$m->{tags}} );
1266     my $feed_entry = XML::Feed::Entry->new($type);
1267     $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1268     $feed_entry->author( $m->{nick} );
1269     $feed_entry->link( '/#' . $m->{id} );
1270     $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1271    
1272     my $message = $filter->{message}->( $m->{message} );
1273     $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1274 dpavlin 79 # warn "## message = $message\n";
1275 dpavlin 77
1276     #$feed_entry->summary(
1277     $feed_entry->content(
1278     "<![CDATA[$message]]>"
1279     );
1280     $feed_entry->category( join(', ', @{$m->{tags}}) );
1281     $feed->add_entry( $feed_entry );
1282 dpavlin 79
1283     $nr--;
1284     last if $nr <= 0;
1285    
1286 dpavlin 77 }
1287 dpavlin 79
1288 dpavlin 85 } elsif ( $show =~ m/^follow/ ) {
1289    
1290     $feed->title( "Feeds which this bot follows" );
1291    
1292     my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1293     $sth->execute;
1294     while (my $row = $sth->fetchrow_hashref) {
1295     my $feed_entry = XML::Feed::Entry->new($type);
1296     $feed_entry->title( $row->{name} );
1297     $feed_entry->link( $row->{url} );
1298     $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1299     $feed_entry->content(
1300     '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1301     );
1302     $feed->add_entry( $feed_entry );
1303     }
1304    
1305 dpavlin 108 } elsif ( $show =~ m/^stat/ ) {
1306    
1307 dpavlin 97 my $feed_entry = XML::Feed::Entry->new($type);
1308     $feed_entry->title( "Internal stats" );
1309     $feed_entry->content(
1310 dpavlin 108 '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1311 dpavlin 97 );
1312     $feed->add_entry( $feed_entry );
1313    
1314 dpavlin 79 } else {
1315 dpavlin 114 _log "WEB unknown rss request $r_url";
1316 dpavlin 108 $feed->title( "unknown $r_url" );
1317     foreach my $c ( @commands ) {
1318     my $feed_entry = XML::Feed::Entry->new($type);
1319     $feed_entry->title( "rss/$c" );
1320     $feed_entry->link( "$url/rss/$c" );
1321     $feed->add_entry( $feed_entry );
1322     }
1323     $rc = RC_DENY;
1324 dpavlin 70 }
1325    
1326 dpavlin 140 eval { $response->content( $feed->as_xml ); };
1327     $rc = RC_INTERNAL_SERVER_ERROR if $@;
1328 dpavlin 108 return $rc;
1329 dpavlin 70 }
1330    
1331     if ( $@ ) {
1332     warn "$@";
1333     }
1334    
1335 dpavlin 86 $response->content_type("text/html; charset=UTF-8");
1336 dpavlin 70
1337 dpavlin 35 my $html =
1338 dpavlin 77 qq{<html><head><title>$NICK</title><style type="text/css">$style}
1339     . $cloud->css
1340 dpavlin 148 . qq{</style>
1341     <meta name="google-site-verification" content="oe-LvUiNiQRPpc_uB-3rY4MWvFifkmLf276WzAvTL5U" />
1342     </head><body>}
1343 dpavlin 77 . qq{
1344 dpavlin 32 <form method="post" class="search" action="/">
1345 dpavlin 16 <input type="text" name="search" value="$search" size="10">
1346     <input type="submit" value="search">
1347     </form>
1348 dpavlin 77 }
1349     . $cloud->html(500)
1350     . qq{<p>};
1351 dpavlin 76
1352     if ($request->url =~ m#/tags?#) {
1353     # nop
1354     } elsif ($request->url =~ m#/history#) {
1355 dpavlin 35 my $sth = $dbh->prepare(qq{
1356 dpavlin 65 select date(time) as date,count(*) as nr,sum(length(message)) as len
1357 dpavlin 35 from log
1358     group by date(time)
1359     order by date(time) desc
1360     });
1361     $sth->execute();
1362     my ($l_yyyy,$l_mm) = (0,0);
1363 dpavlin 65 $html .= qq{<table class="calendar"><tr>};
1364 dpavlin 35 my $cal;
1365 dpavlin 65 my $ord = 0;
1366 dpavlin 35 while (my $row = $sth->fetchrow_hashref) {
1367     # this is probably PostgreSQL specific, expects ISO date
1368     my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1369     if ($yyyy != $l_yyyy || $mm != $l_mm) {
1370 dpavlin 65 if ( $cal ) {
1371     $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1372     $ord++;
1373     $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1374     }
1375 dpavlin 35 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1376 dpavlin 65 $cal->border(1);
1377     $cal->width('30%');
1378     $cal->cellheight('5em');
1379     $cal->tableclass('month');
1380     #$cal->cellclass('day');
1381     $cal->sunday('SUN');
1382     $cal->saturday('SAT');
1383     $cal->weekdays('MON','TUE','WED','THU','FRI');
1384 dpavlin 35 ($l_yyyy,$l_mm) = ($yyyy,$mm);
1385     }
1386 dpavlin 79 $cal->setcontent($dd, qq[
1387 dpavlin 73 <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1388 dpavlin 89 ]) if $cal;
1389 dpavlin 65
1390 dpavlin 35 }
1391 dpavlin 65 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1392 dpavlin 35
1393     } else {
1394     $html .= join("</p><p>",
1395 dpavlin 13 get_from_log(
1396 dpavlin 134 limit => ( $q->param('date') ? undef : $q->param('last') || 100 ),
1397 dpavlin 28 search => $search || undef,
1398 dpavlin 29 tag => $q->param('tag') || undef,
1399 dpavlin 68 date => $q->param('date') || undef,
1400 dpavlin 13 fmt => {
1401 dpavlin 35 date => sub {
1402     my $date = shift || return;
1403 dpavlin 73 qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1404 dpavlin 35 },
1405 dpavlin 13 time => '<span class="time">%s</span> ',
1406     time_channel => '<span class="channel">%s %s</span> ',
1407 dpavlin 20 nick => '%s:&nbsp;',
1408     me_nick => '***%s&nbsp;',
1409 dpavlin 13 message => '<span class="message">%s</span>',
1410     },
1411 dpavlin 70 filter => $filter,
1412 dpavlin 13 )
1413 dpavlin 35 );
1414     }
1415    
1416     $html .= qq{</p>
1417     <hr/>
1418     <p>See <a href="/history">history</a> of all messages.</p>
1419     </body></html>};
1420    
1421 dpavlin 137 $response->content( $html );
1422 dpavlin 74 warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1423 dpavlin 13 return RC_OK;
1424     }
1425    
1426 dpavlin 4 POE::Kernel->run;
1427 dpavlin 133
1428     =head1 TagCloud
1429    
1430     Extended L<HTML::TagCloud>
1431    
1432     =cut
1433    
1434     package TagCloud;
1435     use warnings;
1436     use strict;
1437     use HTML::TagCloud;
1438     use base 'HTML::TagCloud';
1439     use Data::Dump qw/dump/;
1440    
1441     =head2 html
1442    
1443     Generate html with number of tags in title of link
1444    
1445     =cut
1446    
1447     sub html {
1448     my($self, $limit) = @_;
1449     my @tags=$self->tags($limit);
1450    
1451     my $ntags = scalar(@tags);
1452     if ($ntags == 0) {
1453     return "";
1454     # } elsif ($ntags == 1) {
1455     # my $tag = $tags[0];
1456     # return qq{<div id="htmltagcloud"><span class="tagcloud1"><a href="}.
1457     # $tag->{url}.qq{">}.$tag->{name}.qq{</a></span></div>\n};
1458     }
1459    
1460     my $html = qq{<div id="htmltagcloud">};
1461 dpavlin 139 foreach my $tag ( sort { lc($a->{name}) cmp lc($b->{name}) } @tags) {
1462 dpavlin 133 $html .= sprintf(qq{<span class="tag tagcloud%d"><a href="%s" title="%s">%s</a></span>\n},
1463     $tag->{level}, $tag->{url}, $tag->{count}, $tag->{name}
1464     );
1465     }
1466     $html .= qq{</div>};
1467     return $html;
1468     }
1469    
1470     =head2 last_tags
1471    
1472     my @tags = $cloud->last_tags;
1473    
1474     =cut
1475    
1476     my @last_tags;
1477     sub last_tags {
1478     return @last_tags;
1479     }
1480    
1481     =head2 add_tag
1482    
1483     $cloud->add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
1484    
1485     =cut
1486    
1487    
1488     sub add_tag {
1489     my $self = shift;
1490     my $arg = {@_};
1491    
1492     return unless ($arg->{id} && $arg->{message});
1493    
1494     my $m = $arg->{message};
1495    
1496     my @tags;
1497    
1498     while ($m =~ s#$tag_regex##s) {
1499     my $tag = $1;
1500     next if (! $tag || $tag =~ m/https?:/i);
1501     push @{ $tags->{$tag} }, $arg->{id};
1502     #warn "+tag $tag: $arg->{id}\n";
1503     $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1504     push @tags, $tag;
1505    
1506     }
1507    
1508     if ( @tags ) {
1509     pop @last_tags if $#last_tags == $last_x_tags;
1510     unshift @last_tags, { tags => [ @tags ], %$arg };
1511     }
1512    
1513     }
1514    
1515     =head2 seed_tags
1516    
1517     Read all tags from database and create in-memory cache for tags
1518    
1519     =cut
1520    
1521     sub seed_tags {
1522     my $self = shift;
1523     my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
1524     $sth->execute;
1525     while (my $row = $sth->fetchrow_hashref) {
1526     $self->add_tag( %$row );
1527     }
1528    
1529     foreach my $tag (keys %$tags) {
1530     $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1531     }
1532     }
1533    

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26