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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26