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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26