/[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 142 - (hide annotations)
Fri Feb 6 14:17:44 2009 UTC (15 years, 1 month ago) by dpavlin
File MIME type: text/plain
File size: 37638 byte(s)
removed /italic/ which clash too many times with /dev/hda and similar text
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 16 my $q;
1177    
1178     if ( $request->method eq 'POST' ) {
1179     $q = new CGI::Simple( $request->content );
1180     } elsif ( $request->uri =~ /\?(.+)$/ ) {
1181     $q = new CGI::Simple( $1 );
1182     } else {
1183     $q = new CGI::Simple;
1184     }
1185    
1186     my $search = $q->param('search') || $q->param('grep') || '';
1187 dpavlin 108 my $r_url = $request->url;
1188 dpavlin 16
1189 dpavlin 108 my @commands = qw( tags last-tag follow stat );
1190     my $commands_re = join('|',@commands);
1191    
1192     if ($r_url =~ m#/rss(?:/($commands_re.*)\w*(?:=(\d+))?)?#i) {
1193 dpavlin 77 my $show = lc($1);
1194 dpavlin 79 my $nr = $2;
1195 dpavlin 77
1196 dpavlin 71 my $type = 'RSS'; # Atom
1197 dpavlin 70
1198 dpavlin 72 $response->content_type( 'application/' . lc($type) . '+xml' );
1199 dpavlin 70
1200     my $html = '<!-- error -->';
1201 dpavlin 133 #warn "create $type feed from ",dump( $cloud->last_tags );
1202 dpavlin 70
1203     my $feed = XML::Feed->new( $type );
1204 dpavlin 85 $feed->link( $url );
1205 dpavlin 70
1206 dpavlin 108 my $rc = RC_OK;
1207    
1208 dpavlin 77 if ( $show eq 'tags' ) {
1209 dpavlin 79 $nr ||= 50;
1210 dpavlin 77 $feed->title( "tags from $CHANNEL" );
1211     $feed->link( "$url/tags" );
1212     $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1213 dpavlin 70 my $feed_entry = XML::Feed::Entry->new($type);
1214 dpavlin 79 $feed_entry->title( "$nr tags from $CHANNEL" );
1215 dpavlin 77 $feed_entry->author( $NICK );
1216     $feed_entry->link( '/#tags' );
1217 dpavlin 75
1218 dpavlin 73 $feed_entry->content(
1219 dpavlin 77 qq{<![CDATA[<style type="text/css">}
1220     . $cloud->css
1221     . qq{</style>}
1222 dpavlin 79 . $cloud->html( $nr )
1223 dpavlin 77 . qq{]]>}
1224 dpavlin 70 );
1225     $feed->add_entry( $feed_entry );
1226 dpavlin 77
1227 dpavlin 79 } elsif ( $show eq 'last-tag' ) {
1228 dpavlin 77
1229 dpavlin 79 $nr ||= $last_x_tags;
1230 dpavlin 80 $nr = $last_x_tags if $nr > $last_x_tags;
1231 dpavlin 79
1232     $feed->title( "last $nr tagged messages from $CHANNEL" );
1233 dpavlin 77 $feed->description( "collects messages which have tags// in them" );
1234    
1235 dpavlin 133 foreach my $m ( $cloud->last_tags ) {
1236 dpavlin 77 # warn dump( $m );
1237     #my $tags = join(' ', @{$m->{tags}} );
1238     my $feed_entry = XML::Feed::Entry->new($type);
1239     $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1240     $feed_entry->author( $m->{nick} );
1241     $feed_entry->link( '/#' . $m->{id} );
1242     $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1243    
1244     my $message = $filter->{message}->( $m->{message} );
1245     $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1246 dpavlin 79 # warn "## message = $message\n";
1247 dpavlin 77
1248     #$feed_entry->summary(
1249     $feed_entry->content(
1250     "<![CDATA[$message]]>"
1251     );
1252     $feed_entry->category( join(', ', @{$m->{tags}}) );
1253     $feed->add_entry( $feed_entry );
1254 dpavlin 79
1255     $nr--;
1256     last if $nr <= 0;
1257    
1258 dpavlin 77 }
1259 dpavlin 79
1260 dpavlin 85 } elsif ( $show =~ m/^follow/ ) {
1261    
1262     $feed->title( "Feeds which this bot follows" );
1263    
1264     my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1265     $sth->execute;
1266     while (my $row = $sth->fetchrow_hashref) {
1267     my $feed_entry = XML::Feed::Entry->new($type);
1268     $feed_entry->title( $row->{name} );
1269     $feed_entry->link( $row->{url} );
1270     $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1271     $feed_entry->content(
1272     '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1273     );
1274     $feed->add_entry( $feed_entry );
1275     }
1276    
1277 dpavlin 108 } elsif ( $show =~ m/^stat/ ) {
1278    
1279 dpavlin 97 my $feed_entry = XML::Feed::Entry->new($type);
1280     $feed_entry->title( "Internal stats" );
1281     $feed_entry->content(
1282 dpavlin 108 '<![CDATA[<pre>' . dump( $_stat ) . '</pre>]]>'
1283 dpavlin 97 );
1284     $feed->add_entry( $feed_entry );
1285    
1286 dpavlin 79 } else {
1287 dpavlin 114 _log "WEB unknown rss request $r_url";
1288 dpavlin 108 $feed->title( "unknown $r_url" );
1289     foreach my $c ( @commands ) {
1290     my $feed_entry = XML::Feed::Entry->new($type);
1291     $feed_entry->title( "rss/$c" );
1292     $feed_entry->link( "$url/rss/$c" );
1293     $feed->add_entry( $feed_entry );
1294     }
1295     $rc = RC_DENY;
1296 dpavlin 70 }
1297    
1298 dpavlin 140 eval { $response->content( $feed->as_xml ); };
1299     $rc = RC_INTERNAL_SERVER_ERROR if $@;
1300 dpavlin 108 return $rc;
1301 dpavlin 70 }
1302    
1303     if ( $@ ) {
1304     warn "$@";
1305     }
1306    
1307 dpavlin 86 $response->content_type("text/html; charset=UTF-8");
1308 dpavlin 70
1309 dpavlin 35 my $html =
1310 dpavlin 77 qq{<html><head><title>$NICK</title><style type="text/css">$style}
1311     . $cloud->css
1312     . qq{</style></head><body>}
1313     . qq{
1314 dpavlin 32 <form method="post" class="search" action="/">
1315 dpavlin 16 <input type="text" name="search" value="$search" size="10">
1316     <input type="submit" value="search">
1317     </form>
1318 dpavlin 77 }
1319     . $cloud->html(500)
1320     . qq{<p>};
1321 dpavlin 76
1322     if ($request->url =~ m#/tags?#) {
1323     # nop
1324     } elsif ($request->url =~ m#/history#) {
1325 dpavlin 35 my $sth = $dbh->prepare(qq{
1326 dpavlin 65 select date(time) as date,count(*) as nr,sum(length(message)) as len
1327 dpavlin 35 from log
1328     group by date(time)
1329     order by date(time) desc
1330     });
1331     $sth->execute();
1332     my ($l_yyyy,$l_mm) = (0,0);
1333 dpavlin 65 $html .= qq{<table class="calendar"><tr>};
1334 dpavlin 35 my $cal;
1335 dpavlin 65 my $ord = 0;
1336 dpavlin 35 while (my $row = $sth->fetchrow_hashref) {
1337     # this is probably PostgreSQL specific, expects ISO date
1338     my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1339     if ($yyyy != $l_yyyy || $mm != $l_mm) {
1340 dpavlin 65 if ( $cal ) {
1341     $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1342     $ord++;
1343     $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1344     }
1345 dpavlin 35 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1346 dpavlin 65 $cal->border(1);
1347     $cal->width('30%');
1348     $cal->cellheight('5em');
1349     $cal->tableclass('month');
1350     #$cal->cellclass('day');
1351     $cal->sunday('SUN');
1352     $cal->saturday('SAT');
1353     $cal->weekdays('MON','TUE','WED','THU','FRI');
1354 dpavlin 35 ($l_yyyy,$l_mm) = ($yyyy,$mm);
1355     }
1356 dpavlin 79 $cal->setcontent($dd, qq[
1357 dpavlin 73 <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1358 dpavlin 89 ]) if $cal;
1359 dpavlin 65
1360 dpavlin 35 }
1361 dpavlin 65 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1362 dpavlin 35
1363     } else {
1364     $html .= join("</p><p>",
1365 dpavlin 13 get_from_log(
1366 dpavlin 134 limit => ( $q->param('date') ? undef : $q->param('last') || 100 ),
1367 dpavlin 28 search => $search || undef,
1368 dpavlin 29 tag => $q->param('tag') || undef,
1369 dpavlin 68 date => $q->param('date') || undef,
1370 dpavlin 13 fmt => {
1371 dpavlin 35 date => sub {
1372     my $date = shift || return;
1373 dpavlin 73 qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1374 dpavlin 35 },
1375 dpavlin 13 time => '<span class="time">%s</span> ',
1376     time_channel => '<span class="channel">%s %s</span> ',
1377 dpavlin 20 nick => '%s:&nbsp;',
1378     me_nick => '***%s&nbsp;',
1379 dpavlin 13 message => '<span class="message">%s</span>',
1380     },
1381 dpavlin 70 filter => $filter,
1382 dpavlin 13 )
1383 dpavlin 35 );
1384     }
1385    
1386     $html .= qq{</p>
1387     <hr/>
1388     <p>See <a href="/history">history</a> of all messages.</p>
1389     </body></html>};
1390    
1391 dpavlin 137 $response->content( $html );
1392 dpavlin 74 warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1393 dpavlin 13 return RC_OK;
1394     }
1395    
1396 dpavlin 4 POE::Kernel->run;
1397 dpavlin 133
1398     =head1 TagCloud
1399    
1400     Extended L<HTML::TagCloud>
1401    
1402     =cut
1403    
1404     package TagCloud;
1405     use warnings;
1406     use strict;
1407     use HTML::TagCloud;
1408     use base 'HTML::TagCloud';
1409     use Data::Dump qw/dump/;
1410    
1411     =head2 html
1412    
1413     Generate html with number of tags in title of link
1414    
1415     =cut
1416    
1417     sub html {
1418     my($self, $limit) = @_;
1419     my @tags=$self->tags($limit);
1420    
1421     my $ntags = scalar(@tags);
1422     if ($ntags == 0) {
1423     return "";
1424     # } elsif ($ntags == 1) {
1425     # my $tag = $tags[0];
1426     # return qq{<div id="htmltagcloud"><span class="tagcloud1"><a href="}.
1427     # $tag->{url}.qq{">}.$tag->{name}.qq{</a></span></div>\n};
1428     }
1429    
1430     my $html = qq{<div id="htmltagcloud">};
1431 dpavlin 139 foreach my $tag ( sort { lc($a->{name}) cmp lc($b->{name}) } @tags) {
1432 dpavlin 133 $html .= sprintf(qq{<span class="tag tagcloud%d"><a href="%s" title="%s">%s</a></span>\n},
1433     $tag->{level}, $tag->{url}, $tag->{count}, $tag->{name}
1434     );
1435     }
1436     $html .= qq{</div>};
1437     return $html;
1438     }
1439    
1440     =head2 last_tags
1441    
1442     my @tags = $cloud->last_tags;
1443    
1444     =cut
1445    
1446     my @last_tags;
1447     sub last_tags {
1448     return @last_tags;
1449     }
1450    
1451     =head2 add_tag
1452    
1453     $cloud->add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
1454    
1455     =cut
1456    
1457    
1458     sub add_tag {
1459     my $self = shift;
1460     my $arg = {@_};
1461    
1462     return unless ($arg->{id} && $arg->{message});
1463    
1464     my $m = $arg->{message};
1465    
1466     my @tags;
1467    
1468     while ($m =~ s#$tag_regex##s) {
1469     my $tag = $1;
1470     next if (! $tag || $tag =~ m/https?:/i);
1471     push @{ $tags->{$tag} }, $arg->{id};
1472     #warn "+tag $tag: $arg->{id}\n";
1473     $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1474     push @tags, $tag;
1475    
1476     }
1477    
1478     if ( @tags ) {
1479     pop @last_tags if $#last_tags == $last_x_tags;
1480     unshift @last_tags, { tags => [ @tags ], %$arg };
1481     }
1482    
1483     }
1484    
1485     =head2 seed_tags
1486    
1487     Read all tags from database and create in-memory cache for tags
1488    
1489     =cut
1490    
1491     sub seed_tags {
1492     my $self = shift;
1493     my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
1494     $sth->execute;
1495     while (my $row = $sth->fetchrow_hashref) {
1496     $self->add_tag( %$row );
1497     }
1498    
1499     foreach my $tag (keys %$tags) {
1500     $self->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}});
1501     }
1502     }
1503    

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26