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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26