/[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

Contents of /trunk/bin/irc-logger.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 87 - (show annotations)
Fri Mar 7 00:18:02 2008 UTC (12 years, 5 months ago) by dpavlin
File MIME type: text/plain
File size: 30523 byte(s)
- remove log following which doesn't work anyway
- cleanup of $sth for log insert
1 #!/usr/bin/perl -w
2 use strict;
3 $|++;
4
5 =head1 NAME
6
7 irc-logger.pl
8
9 =head1 SYNOPSIS
10
11 ./irc-logger.pl
12
13 =head2 Options
14
15 =over 4
16
17 =item --import-dircproxy=filename
18
19 Import log from C<dircproxy> to C<irc-logger> database
20
21 =item --log=irc-logger.log
22
23 Name of log file
24
25 =item --follow=file.log
26
27 Follows new messages in file
28
29 =back
30
31 =head1 DESCRIPTION
32
33 log all conversation on irc channel
34
35 =cut
36
37 ## CONFIG
38
39 my $HOSTNAME = `hostname -f`;
40 chomp($HOSTNAME);
41
42 my $NICK = 'irc-logger';
43 $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
44 my $CONNECT =
45 {Server => 'irc.freenode.net',
46 Nick => $NICK,
47 Ircname => "try /msg $NICK help",
48 };
49 my $CHANNEL = '#razmjenavjestina';
50 $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
51 my $IRC_ALIAS = "log";
52
53 # default log to follow and announce messages
54 my $follows_path = 'follows.log';
55
56 my $DSN = 'DBI:Pg:dbname=' . $NICK;
57
58 # log output encoding
59 my $ENCODING = 'ISO-8859-2';
60 my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
61
62 my $sleep_on_error = 5;
63
64 # number of last tags to keep in circular buffer
65 my $last_x_tags = 50;
66
67 # don't pull rss feeds more often than this
68 my $rss_min_delay = 60;
69 $rss_min_delay = 15;
70
71 my $http_port = $NICK =~ m/-dev/ ? 8001 : 8000;
72
73 my $url = "http://$HOSTNAME:$http_port";
74
75 ## END CONFIG
76
77 use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
78 use HTTP::Status;
79 use DBI;
80 use Encode qw/from_to is_utf8/;
81 use Regexp::Common qw /URI/;
82 use CGI::Simple;
83 use HTML::TagCloud;
84 use POSIX qw/strftime/;
85 use HTML::CalendarMonthSimple;
86 use Getopt::Long;
87 use DateTime;
88 use URI::Escape;
89 use Data::Dump qw/dump/;
90 use DateTime::Format::ISO8601;
91 use Carp qw/confess/;
92 use XML::Feed;
93 use DateTime::Format::Flexible;
94
95 my $use_twitter = 1;
96 eval { require Net::Twitter; };
97 $use_twitter = 0 if ($@);
98
99 my $import_dircproxy;
100 my $log_path;
101 GetOptions(
102 'import-dircproxy:s' => \$import_dircproxy,
103 'follows:s' => \$follows_path,
104 'log:s' => \$log_path,
105 );
106
107 #$SIG{__DIE__} = sub {
108 # confess "fatal error";
109 #};
110
111 open(STDOUT, '>', $log_path) || warn "can't redirect log to $log_path: $!";
112
113 sub _log {
114 my $out = strftime($TIMESTAMP,localtime()) . ' ' . join(" ",@_) . $/;
115 from_to( $out, 'UTF-8', $ENCODING );
116 print $out;
117 }
118
119 # LOG following
120
121 my %FOLLOWS =
122 (
123 # ACCESS => "/var/log/apache/access.log",
124 # ERROR => "/var/log/apache/error.log",
125 );
126
127 sub add_follow_path {
128 my $path = shift;
129 my $name = $path;
130 $name =~ s/\..*$//;
131 warn "# using $path to announce messages from $name\n";
132 $FOLLOWS{$name} = $path;
133 }
134
135 add_follow_path( $follows_path ) if ( -e $follows_path );
136
137 # HTML formatters
138
139 my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
140 my $escape_re = join '|' => keys %escape;
141
142 my $tag_regex = '\b([\w-_]+)//';
143
144 my %nick_enumerator;
145 my $max_color = 0;
146
147 my $filter = {
148 message => sub {
149 my $m = shift || return;
150
151 # protect HTML from wiki modifications
152 sub e {
153 my $t = shift;
154 return 'uri_unescape{' . uri_escape($t) . '}';
155 }
156
157 $m =~ s/($escape_re)/$escape{$1}/gs;
158 $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs ||
159 $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
160 $m =~ s#$tag_regex#e(qq{<a href="$url?tag=$1" class="tag">$1</a>})#egs;
161 $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
162 $m =~ s#_(\w+)_#<u>$1</u>#gs;
163
164 $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
165 return $m;
166 },
167 nick => sub {
168 my $n = shift || return;
169 if (! $nick_enumerator{$n}) {
170 my $max = scalar keys %nick_enumerator;
171 $nick_enumerator{$n} = $max + 1;
172 }
173 return '<span class="nick col-' .
174 ( $nick_enumerator{$n} % $max_color ) .
175 '">' . $n . '</span>';
176 },
177 };
178
179 my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
180
181 my $sql_schema = {
182 log => qq{
183 create table log (
184 id serial,
185 time timestamp default now(),
186 channel text not null,
187 me boolean default false,
188 nick text not null,
189 message text not null,
190 primary key(id)
191 );
192
193 create index log_time on log(time);
194 create index log_channel on log(channel);
195 create index log_nick on log(nick);
196 },
197 meta => q{
198 create table meta (
199 nick text not null,
200 channel text not null,
201 name text not null,
202 value text,
203 changed timestamp default 'now()',
204 primary key(nick,channel,name)
205 );
206 },
207 feeds => qq{
208 create table feeds (
209 id serial,
210 url text not null,
211 name text,
212 delay interval not null default '5 min',
213 active boolean default true,
214 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 insert into feeds (url,name) values ('http://wiki.razmjenavjestina.org/feed/workspace/razmjenavjestina?category=Recent%20Changes','wiki');
220 },
221 };
222
223 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 }
234
235
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 _log "created $nick/$channel/$name = $value";
264 } else {
265 _log "updated $nick/$channel/$name = $value ";
266 }
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 _log "fetched $nick/$channel/$name = $v [$c]";
276 return ($v,$c) if wantarray;
277 return $v;
278
279 }
280 }
281
282
283
284 my $sth_insert_log = $dbh->prepare(qq{
285 insert into log
286 (channel, me, nick, message, time)
287 values (?,?,?,?,?)
288 });
289
290
291 my $tags;
292
293 =head2 get_from_log
294
295 my @messages = get_from_log(
296 limit => 42,
297 search => '%what to stuff in ilike%',
298 fmt => {
299 time => '{%s} ',
300 time_channel => '{%s %s} ',
301 nick => '%s: ',
302 me_nick => '***%s ',
303 message => '%s',
304 },
305 filter => {
306 message => sub {
307 # modify message content
308 return shift;
309 }
310 },
311 context => 5,
312 full_rows => 1,
313 );
314
315 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 C<context> defines number of messages around each search hit for display.
319
320 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 =cut
324
325 sub get_from_log {
326 my $args = {@_};
327
328 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
339 my $sql_message = qq{
340 select
341 time::date as date,
342 time::time as time,
343 channel,
344 me,
345 nick,
346 message
347 from log
348 };
349
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 sub check_date {
361 my $date = shift || return;
362 my $new_date = eval { DateTime::Format::ISO8601->parse_datetime( $date )->ymd; };
363 if ( $@ ) {
364 warn "invalid date $date\n";
365 $new_date = DateTime->now->ymd;
366 }
367 return $new_date;
368 }
369
370 my @where;
371 my @args;
372
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 _log "search for '$search'";
379 }
380
381 if ($args->{tag} && $tags->{ $args->{tag} }) {
382 push @where, 'id in (' . join(',', @{ $tags->{ $args->{tag} } }) . ')';
383 _log "search for tags $args->{tag}";
384 }
385
386 if (my $date = $args->{date} ) {
387 $date = check_date( $date );
388 push @where, 'date(time) = ?';
389 push @args, $date;
390 _log "search for date $date";
391 }
392
393 $sql .= " where " . join(" and ", @where) if @where;
394
395 $sql .= " order by log.time desc";
396 $sql .= " limit " . $args->{limit} if ($args->{limit});
397
398 #warn "### sql: $sql ", dump( @args );
399
400 my $sth = $dbh->prepare( $sql );
401 eval { $sth->execute( @args ) };
402 return if $@;
403
404 my $last_row = {
405 date => '',
406 time => '',
407 channel => '',
408 nick => '',
409 };
410
411 my @rows;
412
413 while (my $row = $sth->fetchrow_hashref) {
414 unshift @rows, $row;
415 }
416
417 # normalize nick names
418 map {
419 $_->{nick} =~ s/^_*(.*?)_*$/$1/
420 } @rows;
421
422 return @rows if ($args->{full_rows});
423
424 my @msgs = (
425 "Showing " . ($#rows + 1) . " messages..."
426 );
427
428 if ($context) {
429 my @ids = @rows;
430 @rows = ();
431
432 my $last_to = 0;
433
434 my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
435 foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
436 my $id = $row_id->{id} || die "can't find id in row";
437
438 my ($from, $to) = ($id - $context, $id + $context);
439 $from = $last_to if ($from < $last_to);
440 $last_to = $to;
441 $sth->execute( $from, $to );
442
443 #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
444
445 while (my $row = $sth->fetchrow_hashref) {
446 push @rows, $row;
447 }
448
449 }
450 }
451
452 # sprintf which can take coderef as first parametar
453 sub cr_sprintf {
454 my $fmt = shift || return;
455 if (ref($fmt) eq 'CODE') {
456 $fmt->(@_);
457 } else {
458 sprintf($fmt, @_);
459 }
460 }
461
462 foreach my $row (@rows) {
463
464 $row->{time} =~ s#\.\d+##;
465
466 my $msg = '';
467
468 $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
469 my $t = $row->{time};
470
471 if ($last_row->{channel} ne $row->{channel}) {
472 $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
473 } else {
474 $msg .= cr_sprintf($args->{fmt}->{time}, $t);
475 }
476
477 my $append = 1;
478
479 my $nick = $row->{nick};
480 # if ($nick =~ s/^_*(.*?)_*$/$1/) {
481 # $row->{nick} = $nick;
482 # }
483
484 if ($last_row->{nick} ne $nick) {
485 # obfu way to find format for me_nick if needed or fallback to default
486 my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
487 $fmt ||= '%s';
488
489 $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
490
491 $msg .= cr_sprintf( $fmt, $nick );
492 $append = 0;
493 }
494
495 $args->{fmt}->{message} ||= '%s';
496 if (ref($args->{filter}->{message}) eq 'CODE') {
497 $msg .= cr_sprintf($args->{fmt}->{message},
498 $args->{filter}->{message}->(
499 $row->{message}
500 )
501 );
502 } else {
503 $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
504 }
505
506 if ($append && @msgs) {
507 $msgs[$#msgs] .= " " . $msg;
508 } else {
509 push @msgs, $msg;
510 }
511
512 $last_row = $row;
513 }
514
515 return @msgs;
516 }
517
518 # tags support
519
520 my $cloud = HTML::TagCloud->new;
521
522 =head2 add_tag
523
524 add_tag( id => 42, message => 'irc message', nick => 'foobar' [, me => 1 ] );
525
526 =cut
527
528 my @last_tags;
529
530 sub add_tag {
531 my $arg = {@_};
532
533 return unless ($arg->{id} && $arg->{message});
534
535 my $m = $arg->{message};
536 from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
537
538 my @tags;
539
540 while ($m =~ s#$tag_regex##s) {
541 my $tag = $1;
542 next if (! $tag || $tag =~ m/https?:/i);
543 push @{ $tags->{$tag} }, $arg->{id};
544 #warn "+tag $tag: $arg->{id}\n";
545 $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
546 push @tags, $tag;
547
548 }
549
550 if ( @tags ) {
551 pop @last_tags if $#last_tags == $last_x_tags;
552 unshift @last_tags, { tags => [ @tags ], %$arg };
553 }
554
555 }
556
557 =head2 seed_tags
558
559 Read all tags from database and create in-memory cache for tags
560
561 =cut
562
563 sub seed_tags {
564 my $sth = $dbh->prepare(qq{ select id,message,nick,me,time from log where message like '%//%' order by time asc });
565 $sth->execute;
566 while (my $row = $sth->fetchrow_hashref) {
567 add_tag( %$row );
568 }
569
570 foreach my $tag (keys %$tags) {
571 $cloud->add($tag, "$url?tag=$tag", scalar @{$tags->{$tag}} + 1);
572 }
573 }
574
575 seed_tags;
576
577
578 =head2 save_message
579
580 save_message(
581 channel => '#foobar',
582 me => 0,
583 nick => 'dpavlin',
584 message => 'test message',
585 time => '2006-06-25 18:57:18',
586 );
587
588 C<time> is optional, it will use C<< now() >> if it's not available.
589
590 C<me> if not specified will be C<0> (not C</me> message)
591
592 =cut
593
594 sub save_message {
595 my $a = {@_};
596 confess "have msg" if $a->{msg};
597 $a->{me} ||= 0;
598 $a->{time} ||= strftime($TIMESTAMP,localtime());
599
600 _log
601 $a->{channel}, " ",
602 $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
603 " " . $a->{message};
604
605 $sth_insert_log->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{message}, $a->{time});
606 add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef), %$a );
607 }
608
609
610 if ($import_dircproxy) {
611 open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
612 warn "importing $import_dircproxy...\n";
613 my $tz_offset = 1 * 60 * 60; # TZ GMT+2
614 while(<$l>) {
615 chomp;
616 if (/^@(\d+)\s(\S+)\s(.+)$/) {
617 my ($time, $nick, $msg) = ($1,$2,$3);
618
619 my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
620
621 my $me = 0;
622 $me = 1 if ($nick =~ m/^\[\S+]/);
623 $nick =~ s/^[\[<]([^!]+).*$/$1/;
624
625 $msg =~ s/^ACTION\s+// if ($me);
626
627 save_message(
628 channel => $CHANNEL,
629 me => $me,
630 nick => $nick,
631 message => $msg,
632 time => $dt->ymd . " " . $dt->hms,
633 ) if ($nick !~ m/^-/);
634
635 } else {
636 _log "can't parse: $_";
637 }
638 }
639 close($l);
640 warn "import over\n";
641 exit;
642 }
643
644 #
645 # RSS follow
646 #
647
648 my $_rss;
649
650
651 sub rss_fetch {
652 my ($args) = @_;
653
654 # how many messages to send out when feed is seen for the first time?
655 my $send_rss_msgs = 1;
656
657 _log "RSS fetch", $args->{url};
658
659 my $feed = XML::Feed->parse(URI->new( $args->{url} ));
660 if ( ! $feed ) {
661 _log("can't fetch RSS ", $args->{url});
662 return;
663 }
664 my ( $total, $updates ) = ( 0, 0 );
665 for my $entry ($feed->entries) {
666 $total++;
667
668 # seen allready?
669 return if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;
670
671 sub prefix {
672 my ($txt,$var) = @_;
673 $var =~ s/^\s+//g;
674 return $txt . $var if $var;
675 }
676
677 my $msg;
678 $msg .= prefix( 'From: ' , $feed->title );
679 $msg .= prefix( ' by ' , $entry->author );
680 $msg .= prefix( ' -- ' , $entry->link );
681 # $msg .= prefix( ' id ' , $entry->id );
682
683 if ( $args->{kernel} && $send_rss_msgs ) {
684 warn "# sending to $CHANNEL\n";
685 $send_rss_msgs--;
686 $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );
687 $updates++;
688 #$sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, undef );
689 _log('RSS', $msg);
690 }
691 }
692
693 my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
694 $sql .= qq{, updates = updates + $updates } if $updates;
695 $sql .= qq{where id = } . $args->{id};
696 eval { $dbh->do( $sql ) };
697
698 _log "RSS got $total items of which $updates new";
699
700 return $updates;
701 }
702
703 sub rss_fetch_all {
704 my $kernel = shift;
705 my $sql = qq{
706 select id, url, name
707 from feeds
708 where active is true
709 };
710 # limit to newer feeds only if we are not sending messages out
711 $sql .= qq{ and last_update + delay < now() } if $kernel;
712 my $sth = $dbh->prepare( $sql );
713 $sth->execute();
714 warn "# ",$sth->rows," active RSS feeds\n";
715 my $count = 0;
716 while (my $row = $sth->fetchrow_hashref) {
717 $row->{kernel} = $kernel if $kernel;
718 $count += rss_fetch( $row );
719 }
720 return "OK, fetched $count posts from " . $sth->rows . " feeds";
721 }
722
723
724 sub rss_check_updates {
725 my $kernel = shift;
726 my $last_t = $_rss->{last_poll} || time();
727 my $t = time();
728 if ( $last_t - $t > $rss_min_delay ) {
729 $_rss->{last_poll} = $t;
730 _log rss_fetch_all( $kernel );
731 }
732 }
733
734 # seed rss seen cache so we won't send out all items on startup
735 _log rss_fetch_all;
736
737 #
738 # POE handing part
739 #
740
741 my $SKIPPING = 0; # if skipping, how many we've done
742 my $SEND_QUEUE; # cache
743 my $ping; # ping stats
744
745 POE::Component::IRC->new($IRC_ALIAS);
746
747 POE::Session->create( inline_states => {
748 _start => sub {
749 $_[KERNEL]->post($IRC_ALIAS => register => 'all');
750 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
751 },
752 irc_255 => sub { # server is done blabbing
753 $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
754 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
755 },
756 irc_public => sub {
757 my $kernel = $_[KERNEL];
758 my $nick = (split /!/, $_[ARG0])[0];
759 my $channel = $_[ARG1]->[0];
760 my $msg = $_[ARG2];
761
762 save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
763 meta( $nick, $channel, 'last-msg', $msg );
764 },
765 irc_ctcp_action => sub {
766 my $kernel = $_[KERNEL];
767 my $nick = (split /!/, $_[ARG0])[0];
768 my $channel = $_[ARG1]->[0];
769 my $msg = $_[ARG2];
770
771 save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
772
773 if ( $use_twitter ) {
774 if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
775 my ($login,$passwd) = split(/\s+/,$twitter,2);
776 _log("sending twitter for $nick/$login on $channel ");
777 my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
778 $bot->update("<${channel}> $msg");
779 }
780 }
781
782 },
783 irc_ping => sub {
784 _log( "pong ", $_[ARG0] );
785 $ping->{ $_[ARG0] }++;
786 rss_check_updates( $_[KERNEL] );
787 },
788 irc_invite => sub {
789 my $kernel = $_[KERNEL];
790 my $nick = (split /!/, $_[ARG0])[0];
791 my $channel = $_[ARG1];
792
793 _log "invited to $channel by $nick";
794
795 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
796 $_[KERNEL]->post($IRC_ALIAS => join => $channel);
797
798 },
799 irc_msg => sub {
800 my $kernel = $_[KERNEL];
801 my $nick = (split /!/, $_[ARG0])[0];
802 my $msg = $_[ARG2];
803 my $channel = $_[ARG1]->[0];
804
805 my $res = "unknown command '$msg', try /msg $NICK help!";
806 my @out;
807
808 _log "<< $msg";
809
810 if ($msg =~ m/^help/i) {
811
812 $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
813
814 } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
815
816 _log ">> /msg $1 $2";
817 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
818 $res = '';
819
820 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
821
822 my $nr = $1 || 10;
823
824 my $sth = $dbh->prepare(qq{
825 select
826 trim(both '_' from nick) as nick,
827 count(*) as count,
828 sum(length(message)) as len
829 from log
830 group by trim(both '_' from nick)
831 order by len desc,count desc
832 limit $nr
833 });
834 $sth->execute();
835 $res = "Top $nr users: ";
836 my @users;
837 while (my $row = $sth->fetchrow_hashref) {
838 push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
839 }
840 $res .= join(" | ", @users);
841 } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
842
843 my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
844
845 foreach my $res (get_from_log( limit => $limit )) {
846 _log "last: $res";
847 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
848 }
849
850 $res = '';
851
852 } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
853
854 my $what = $2;
855
856 foreach my $res (get_from_log(
857 limit => 20,
858 search => $what,
859 )) {
860 _log "search [$what]: $res";
861 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
862 }
863
864 $res = '';
865
866 } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
867
868 my ($what,$limit) = ($1,$2);
869 $limit ||= 100;
870
871 my $stat;
872
873 foreach my $res (get_from_log(
874 limit => $limit,
875 search => $what,
876 full_rows => 1,
877 )) {
878 while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
879 $stat->{vote}->{$1}++;
880 $stat->{from}->{ $res->{nick} }++;
881 }
882 }
883
884 my @nicks;
885 foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
886 push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
887 "(" . $stat->{from}->{$nick} . ")"
888 );
889 }
890
891 $res =
892 "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
893 " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
894 " from " . ( join(", ", @nicks) || 'nobody' );
895
896 $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
897
898 } elsif ($msg =~ m/^ping/) {
899 $res = "ping = " . dump( $ping );
900 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
901 if ( ! defined( $1 ) ) {
902 my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
903 $sth->execute( $nick, $channel );
904 $res = "config for $nick on $channel";
905 while ( my ($n,$v) = $sth->fetchrow_array ) {
906 $res .= " | $n = $v";
907 }
908 } elsif ( ! $2 ) {
909 my $val = meta( $nick, $channel, $1 );
910 $res = "current $1 = " . ( $val ? $val : 'undefined' );
911 } else {
912 my $validate = {
913 'last-size' => qr/^\d+/,
914 'twitter' => qr/^\w+\s+\w+/,
915 };
916
917 my ( $op, $val ) = ( $1, $2 );
918
919 if ( my $regex = $validate->{$op} ) {
920 if ( $val =~ $regex ) {
921 meta( $nick, $channel, $op, $val );
922 $res = "saved $op = $val";
923 } else {
924 $res = "config option $op = $val doesn't validate against $regex";
925 }
926 } else {
927 $res = "config option $op doesn't exist";
928 }
929 }
930 } elsif ($msg =~ m/^rss-update/) {
931 $res = rss_fetch_all( $_[KERNEL] );
932 } elsif ($msg =~ m/^rss-clean/) {
933 $_rss = undef;
934 $res = "OK, cleaned RSS cache";
935 } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {
936 my $sql = {
937 add => qq{ insert into feeds (url,name) values (?,?) },
938 # remove => qq{ delete from feeds where url = ? and name = ? },
939 start => qq{ update feeds set active = true where url = ? -- ? },
940 stop => qq{ update feeds set active = false where url = ? -- ? },
941
942 };
943 if (my $q = $sql->{$1} ) {
944 my $sth = $dbh->prepare( $q );
945 warn "## SQL $q ( $2 | $3 )\n";
946 eval { $sth->execute( $2, $3 ) };
947 }
948
949 $res ||= "OK, RSS $1 : $2 - $3";
950 }
951
952 if ($res) {
953 _log ">> [$nick] $res";
954 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
955 }
956
957 rss_check_updates( $_[KERNEL] );
958 },
959 irc_477 => sub {
960 _log "# irc_477: ",$_[ARG1];
961 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
962 },
963 irc_505 => sub {
964 _log "# irc_505: ",$_[ARG1];
965 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
966 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
967 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
968 },
969 irc_registered => sub {
970 _log "## registrated $NICK";
971 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
972 },
973 irc_disconnected => sub {
974 _log "## disconnected, reconnecting again";
975 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
976 },
977 irc_socketerr => sub {
978 _log "## socket error... sleeping for $sleep_on_error seconds and retry";
979 sleep($sleep_on_error);
980 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
981 },
982 # irc_433 => sub {
983 # print "# irc_433: ",$_[ARG1], "\n";
984 # warn "## indetify $NICK\n";
985 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
986 # },
987 _child => sub {},
988 _default => sub {
989 _log sprintf "sID:%s %s %s",
990 $_[SESSION]->ID, $_[ARG0],
991 ref($_[ARG1]) eq "ARRAY" ? join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] }) :
992 $_[ARG1] ? $_[ARG1] :
993 "";
994 0; # false for signals
995 },
996 },
997 );
998
999 # http server
1000
1001 my $httpd = POE::Component::Server::HTTP->new(
1002 Port => $http_port,
1003 PreHandler => {
1004 '/' => sub {
1005 $_[0]->header(Connection => 'close')
1006 }
1007 },
1008 ContentHandler => { '/' => \&root_handler },
1009 Headers => { Server => 'irc-logger' },
1010 );
1011
1012 my $style = <<'_END_OF_STYLE_';
1013 p { margin: 0; padding: 0.1em; }
1014 .time, .channel { color: #808080; font-size: 60%; }
1015 .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
1016 .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
1017 .message { color: #000000; font-size: 100%; }
1018 .search { float: right; }
1019 a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
1020 a:hover.tag { border: 1px solid #eee }
1021 hr { border: 1px dashed #ccc; height: 1px; clear: both; }
1022 /*
1023 .col-0 { background: #ffff66 }
1024 .col-1 { background: #a0ffff }
1025 .col-2 { background: #99ff99 }
1026 .col-3 { background: #ff9999 }
1027 .col-4 { background: #ff66ff }
1028 */
1029 .calendar { border: 1px solid red; width: 100%; }
1030 .month { border: 0px; width: 100%; }
1031 _END_OF_STYLE_
1032
1033 $max_color = 0;
1034
1035 my @cols = qw(
1036 #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1037 #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1038 #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1039 #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1040 #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1041 );
1042
1043 foreach my $c (@cols) {
1044 $style .= ".col-${max_color} { background: $c }\n";
1045 $max_color++;
1046 }
1047 warn "defined $max_color colors for users...\n";
1048
1049 sub root_handler {
1050 my ($request, $response) = @_;
1051 $response->code(RC_OK);
1052
1053 # this doesn't seem to work, so moved to PreHandler
1054 #$response->header(Connection => 'close');
1055
1056 return RC_OK if $request->uri =~ m/favicon.ico$/;
1057
1058 my $q;
1059
1060 if ( $request->method eq 'POST' ) {
1061 $q = new CGI::Simple( $request->content );
1062 } elsif ( $request->uri =~ /\?(.+)$/ ) {
1063 $q = new CGI::Simple( $1 );
1064 } else {
1065 $q = new CGI::Simple;
1066 }
1067
1068 my $search = $q->param('search') || $q->param('grep') || '';
1069
1070 if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1071 my $show = lc($1);
1072 my $nr = $2;
1073
1074 my $type = 'RSS'; # Atom
1075
1076 $response->content_type( 'application/' . lc($type) . '+xml' );
1077
1078 my $html = '<!-- error -->';
1079 #warn "create $type feed from ",dump( @last_tags );
1080
1081 my $feed = XML::Feed->new( $type );
1082 $feed->link( $url );
1083
1084 if ( $show eq 'tags' ) {
1085 $nr ||= 50;
1086 $feed->title( "tags from $CHANNEL" );
1087 $feed->link( "$url/tags" );
1088 $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1089 my $feed_entry = XML::Feed::Entry->new($type);
1090 $feed_entry->title( "$nr tags from $CHANNEL" );
1091 $feed_entry->author( $NICK );
1092 $feed_entry->link( '/#tags' );
1093
1094 $feed_entry->content(
1095 qq{<![CDATA[<style type="text/css">}
1096 . $cloud->css
1097 . qq{</style>}
1098 . $cloud->html( $nr )
1099 . qq{]]>}
1100 );
1101 $feed->add_entry( $feed_entry );
1102
1103 } elsif ( $show eq 'last-tag' ) {
1104
1105 $nr ||= $last_x_tags;
1106 $nr = $last_x_tags if $nr > $last_x_tags;
1107
1108 $feed->title( "last $nr tagged messages from $CHANNEL" );
1109 $feed->description( "collects messages which have tags// in them" );
1110
1111 foreach my $m ( @last_tags ) {
1112 # warn dump( $m );
1113 #my $tags = join(' ', @{$m->{tags}} );
1114 my $feed_entry = XML::Feed::Entry->new($type);
1115 $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1116 $feed_entry->author( $m->{nick} );
1117 $feed_entry->link( '/#' . $m->{id} );
1118 $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1119
1120 my $message = $filter->{message}->( $m->{message} );
1121 $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1122 # warn "## message = $message\n";
1123
1124 #$feed_entry->summary(
1125 $feed_entry->content(
1126 "<![CDATA[$message]]>"
1127 );
1128 $feed_entry->category( join(', ', @{$m->{tags}}) );
1129 $feed->add_entry( $feed_entry );
1130
1131 $nr--;
1132 last if $nr <= 0;
1133
1134 }
1135
1136 } elsif ( $show =~ m/^follow/ ) {
1137
1138 $feed->title( "Feeds which this bot follows" );
1139
1140 my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1141 $sth->execute;
1142 while (my $row = $sth->fetchrow_hashref) {
1143 my $feed_entry = XML::Feed::Entry->new($type);
1144 $feed_entry->title( $row->{name} );
1145 $feed_entry->link( $row->{url} );
1146 $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1147 $feed_entry->content(
1148 '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1149 );
1150 $feed->add_entry( $feed_entry );
1151 }
1152
1153 } else {
1154 _log "unknown rss request ",$request->url;
1155 return RC_DENY;
1156 }
1157
1158 $response->content( $feed->as_xml );
1159 return RC_OK;
1160 }
1161
1162 if ( $@ ) {
1163 warn "$@";
1164 }
1165
1166 $response->content_type("text/html; charset=UTF-8");
1167
1168 my $html =
1169 qq{<html><head><title>$NICK</title><style type="text/css">$style}
1170 . $cloud->css
1171 . qq{</style></head><body>}
1172 . qq{
1173 <form method="post" class="search" action="/">
1174 <input type="text" name="search" value="$search" size="10">
1175 <input type="submit" value="search">
1176 </form>
1177 }
1178 . $cloud->html(500)
1179 . qq{<p>};
1180
1181 if ($request->url =~ m#/tags?#) {
1182 # nop
1183 } elsif ($request->url =~ m#/history#) {
1184 my $sth = $dbh->prepare(qq{
1185 select date(time) as date,count(*) as nr,sum(length(message)) as len
1186 from log
1187 group by date(time)
1188 order by date(time) desc
1189 });
1190 $sth->execute();
1191 my ($l_yyyy,$l_mm) = (0,0);
1192 $html .= qq{<table class="calendar"><tr>};
1193 my $cal;
1194 my $ord = 0;
1195 while (my $row = $sth->fetchrow_hashref) {
1196 # this is probably PostgreSQL specific, expects ISO date
1197 my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1198 if ($yyyy != $l_yyyy || $mm != $l_mm) {
1199 if ( $cal ) {
1200 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1201 $ord++;
1202 $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1203 }
1204 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1205 $cal->border(1);
1206 $cal->width('30%');
1207 $cal->cellheight('5em');
1208 $cal->tableclass('month');
1209 #$cal->cellclass('day');
1210 $cal->sunday('SUN');
1211 $cal->saturday('SAT');
1212 $cal->weekdays('MON','TUE','WED','THU','FRI');
1213 ($l_yyyy,$l_mm) = ($yyyy,$mm);
1214 }
1215 $cal->setcontent($dd, qq[
1216 <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1217 ]);
1218
1219 }
1220 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1221
1222 } else {
1223 $html .= join("</p><p>",
1224 get_from_log(
1225 limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1226 search => $search || undef,
1227 tag => $q->param('tag') || undef,
1228 date => $q->param('date') || undef,
1229 fmt => {
1230 date => sub {
1231 my $date = shift || return;
1232 qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1233 },
1234 time => '<span class="time">%s</span> ',
1235 time_channel => '<span class="channel">%s %s</span> ',
1236 nick => '%s:&nbsp;',
1237 me_nick => '***%s&nbsp;',
1238 message => '<span class="message">%s</span>',
1239 },
1240 filter => $filter,
1241 )
1242 );
1243 }
1244
1245 $html .= qq{</p>
1246 <hr/>
1247 <p>See <a href="/history">history</a> of all messages.</p>
1248 </body></html>};
1249
1250 $response->content( $html );
1251 warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1252 return RC_OK;
1253 }
1254
1255 POE::Kernel->run;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26