/[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 91 - (show annotations)
Fri Mar 7 10:13:45 2008 UTC (12 years, 6 months ago) by dpavlin
File MIME type: text/plain
File size: 30113 byte(s)
added rss-list and fixed rss-(stop|start) to actually work
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-list/) {
901 my $sth = $dbh->prepare(qq{ select url,name,last_update,active from feeds });
902 $sth->execute;
903 while (my @row = $sth->fetchrow_array) {
904 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
905 }
906 $res = '';
907 } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {
908 my $sql = {
909 add => qq{ insert into feeds (url,name) values (?,?) },
910 # remove => qq{ delete from feeds where url = ? and name = ? },
911 start => qq{ update feeds set active = true where url = ? },
912 stop => qq{ update feeds set active = false where url = ? },
913
914 };
915 if (my $q = $sql->{$1} ) {
916 my $sth = $dbh->prepare( $q );
917 my @data = ( $2 );
918 push @data, $3 if ( $q =~ s/\?//g == 2 );
919 warn "## $1 SQL $q with ",dump( @data ),"\n";
920 eval { $sth->execute( @data ) };
921 }
922
923 $res = "OK, RSS $1 : $2 - $3";
924 }
925
926 if ($res) {
927 _log ">> [$nick] $res";
928 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
929 }
930
931 rss_check_updates( $_[KERNEL] );
932 },
933 irc_477 => sub {
934 _log "# irc_477: ",$_[ARG1];
935 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
936 },
937 irc_505 => sub {
938 _log "# irc_505: ",$_[ARG1];
939 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
940 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
941 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
942 },
943 irc_registered => sub {
944 _log "## registrated $NICK";
945 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
946 },
947 irc_disconnected => sub {
948 _log "## disconnected, reconnecting again";
949 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
950 },
951 irc_socketerr => sub {
952 _log "## socket error... sleeping for $sleep_on_error seconds and retry";
953 sleep($sleep_on_error);
954 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
955 },
956 # irc_433 => sub {
957 # print "# irc_433: ",$_[ARG1], "\n";
958 # warn "## indetify $NICK\n";
959 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
960 # },
961 _child => sub {},
962 _default => sub {
963 _log sprintf "sID:%s %s %s",
964 $_[SESSION]->ID, $_[ARG0],
965 ref($_[ARG1]) eq "ARRAY" ? join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] }) :
966 $_[ARG1] ? $_[ARG1] :
967 "";
968 0; # false for signals
969 },
970 },
971 );
972
973 # http server
974
975 my $httpd = POE::Component::Server::HTTP->new(
976 Port => $http_port,
977 PreHandler => {
978 '/' => sub {
979 $_[0]->header(Connection => 'close')
980 }
981 },
982 ContentHandler => { '/' => \&root_handler },
983 Headers => { Server => 'irc-logger' },
984 );
985
986 my $style = <<'_END_OF_STYLE_';
987 p { margin: 0; padding: 0.1em; }
988 .time, .channel { color: #808080; font-size: 60%; }
989 .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
990 .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
991 .message { color: #000000; font-size: 100%; }
992 .search { float: right; }
993 a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
994 a:hover.tag { border: 1px solid #eee }
995 hr { border: 1px dashed #ccc; height: 1px; clear: both; }
996 /*
997 .col-0 { background: #ffff66 }
998 .col-1 { background: #a0ffff }
999 .col-2 { background: #99ff99 }
1000 .col-3 { background: #ff9999 }
1001 .col-4 { background: #ff66ff }
1002 */
1003 .calendar { border: 1px solid red; width: 100%; }
1004 .month { border: 0px; width: 100%; }
1005 _END_OF_STYLE_
1006
1007 $max_color = 0;
1008
1009 my @cols = qw(
1010 #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1011 #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1012 #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1013 #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1014 #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1015 );
1016
1017 foreach my $c (@cols) {
1018 $style .= ".col-${max_color} { background: $c }\n";
1019 $max_color++;
1020 }
1021 warn "defined $max_color colors for users...\n";
1022
1023 sub root_handler {
1024 my ($request, $response) = @_;
1025 $response->code(RC_OK);
1026
1027 # this doesn't seem to work, so moved to PreHandler
1028 #$response->header(Connection => 'close');
1029
1030 return RC_OK if $request->uri =~ m/favicon.ico$/;
1031
1032 my $q;
1033
1034 if ( $request->method eq 'POST' ) {
1035 $q = new CGI::Simple( $request->content );
1036 } elsif ( $request->uri =~ /\?(.+)$/ ) {
1037 $q = new CGI::Simple( $1 );
1038 } else {
1039 $q = new CGI::Simple;
1040 }
1041
1042 my $search = $q->param('search') || $q->param('grep') || '';
1043
1044 if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1045 my $show = lc($1);
1046 my $nr = $2;
1047
1048 my $type = 'RSS'; # Atom
1049
1050 $response->content_type( 'application/' . lc($type) . '+xml' );
1051
1052 my $html = '<!-- error -->';
1053 #warn "create $type feed from ",dump( @last_tags );
1054
1055 my $feed = XML::Feed->new( $type );
1056 $feed->link( $url );
1057
1058 if ( $show eq 'tags' ) {
1059 $nr ||= 50;
1060 $feed->title( "tags from $CHANNEL" );
1061 $feed->link( "$url/tags" );
1062 $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1063 my $feed_entry = XML::Feed::Entry->new($type);
1064 $feed_entry->title( "$nr tags from $CHANNEL" );
1065 $feed_entry->author( $NICK );
1066 $feed_entry->link( '/#tags' );
1067
1068 $feed_entry->content(
1069 qq{<![CDATA[<style type="text/css">}
1070 . $cloud->css
1071 . qq{</style>}
1072 . $cloud->html( $nr )
1073 . qq{]]>}
1074 );
1075 $feed->add_entry( $feed_entry );
1076
1077 } elsif ( $show eq 'last-tag' ) {
1078
1079 $nr ||= $last_x_tags;
1080 $nr = $last_x_tags if $nr > $last_x_tags;
1081
1082 $feed->title( "last $nr tagged messages from $CHANNEL" );
1083 $feed->description( "collects messages which have tags// in them" );
1084
1085 foreach my $m ( @last_tags ) {
1086 # warn dump( $m );
1087 #my $tags = join(' ', @{$m->{tags}} );
1088 my $feed_entry = XML::Feed::Entry->new($type);
1089 $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1090 $feed_entry->author( $m->{nick} );
1091 $feed_entry->link( '/#' . $m->{id} );
1092 $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1093
1094 my $message = $filter->{message}->( $m->{message} );
1095 $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1096 # warn "## message = $message\n";
1097
1098 #$feed_entry->summary(
1099 $feed_entry->content(
1100 "<![CDATA[$message]]>"
1101 );
1102 $feed_entry->category( join(', ', @{$m->{tags}}) );
1103 $feed->add_entry( $feed_entry );
1104
1105 $nr--;
1106 last if $nr <= 0;
1107
1108 }
1109
1110 } elsif ( $show =~ m/^follow/ ) {
1111
1112 $feed->title( "Feeds which this bot follows" );
1113
1114 my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1115 $sth->execute;
1116 while (my $row = $sth->fetchrow_hashref) {
1117 my $feed_entry = XML::Feed::Entry->new($type);
1118 $feed_entry->title( $row->{name} );
1119 $feed_entry->link( $row->{url} );
1120 $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1121 $feed_entry->content(
1122 '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1123 );
1124 $feed->add_entry( $feed_entry );
1125 }
1126
1127 } else {
1128 _log "unknown rss request ",$request->url;
1129 return RC_DENY;
1130 }
1131
1132 $response->content( $feed->as_xml );
1133 return RC_OK;
1134 }
1135
1136 if ( $@ ) {
1137 warn "$@";
1138 }
1139
1140 $response->content_type("text/html; charset=UTF-8");
1141
1142 my $html =
1143 qq{<html><head><title>$NICK</title><style type="text/css">$style}
1144 . $cloud->css
1145 . qq{</style></head><body>}
1146 . qq{
1147 <form method="post" class="search" action="/">
1148 <input type="text" name="search" value="$search" size="10">
1149 <input type="submit" value="search">
1150 </form>
1151 }
1152 . $cloud->html(500)
1153 . qq{<p>};
1154
1155 if ($request->url =~ m#/tags?#) {
1156 # nop
1157 } elsif ($request->url =~ m#/history#) {
1158 my $sth = $dbh->prepare(qq{
1159 select date(time) as date,count(*) as nr,sum(length(message)) as len
1160 from log
1161 group by date(time)
1162 order by date(time) desc
1163 });
1164 $sth->execute();
1165 my ($l_yyyy,$l_mm) = (0,0);
1166 $html .= qq{<table class="calendar"><tr>};
1167 my $cal;
1168 my $ord = 0;
1169 while (my $row = $sth->fetchrow_hashref) {
1170 # this is probably PostgreSQL specific, expects ISO date
1171 my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1172 if ($yyyy != $l_yyyy || $mm != $l_mm) {
1173 if ( $cal ) {
1174 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1175 $ord++;
1176 $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1177 }
1178 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1179 $cal->border(1);
1180 $cal->width('30%');
1181 $cal->cellheight('5em');
1182 $cal->tableclass('month');
1183 #$cal->cellclass('day');
1184 $cal->sunday('SUN');
1185 $cal->saturday('SAT');
1186 $cal->weekdays('MON','TUE','WED','THU','FRI');
1187 ($l_yyyy,$l_mm) = ($yyyy,$mm);
1188 }
1189 $cal->setcontent($dd, qq[
1190 <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1191 ]) if $cal;
1192
1193 }
1194 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1195
1196 } else {
1197 $html .= join("</p><p>",
1198 get_from_log(
1199 limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1200 search => $search || undef,
1201 tag => $q->param('tag') || undef,
1202 date => $q->param('date') || undef,
1203 fmt => {
1204 date => sub {
1205 my $date = shift || return;
1206 qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1207 },
1208 time => '<span class="time">%s</span> ',
1209 time_channel => '<span class="channel">%s %s</span> ',
1210 nick => '%s:&nbsp;',
1211 me_nick => '***%s&nbsp;',
1212 message => '<span class="message">%s</span>',
1213 },
1214 filter => $filter,
1215 )
1216 );
1217 }
1218
1219 $html .= qq{</p>
1220 <hr/>
1221 <p>See <a href="/history">history</a> of all messages.</p>
1222 </body></html>};
1223
1224 $response->content( $html );
1225 warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1226 return RC_OK;
1227 }
1228
1229 POE::Kernel->run;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26