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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26