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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26