/[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 92 - (show annotations)
Fri Mar 7 10:30:57 2008 UTC (16 years ago) by dpavlin
File MIME type: text/plain
File size: 30155 byte(s)
- display name of feed item in message
- fixed rss item seen logic
- insert time for rss messages in log
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
632 my ( $total, $updates ) = ( 0, 0 );
633 for my $entry ($feed->entries) {
634 $total++;
635
636 # seen allready?
637 next if $_rss->{$feed->link}->{seen}->{$entry->id}++ > 0;
638
639 sub prefix {
640 my ($txt,$var) = @_;
641 $var =~ s/^\s+//g;
642 return $txt . $var if $var;
643 }
644
645 my $msg;
646 $msg .= prefix( 'From: ' , $args->{name} || $feed->title );
647 $msg .= prefix( ' by ' , $entry->author );
648 $msg .= prefix( ' | ' , $entry->title );
649 $msg .= prefix( ' | ' , $entry->link );
650 # $msg .= prefix( ' id ' , $entry->id );
651
652 if ( $args->{kernel} && $send_rss_msgs ) {
653 $send_rss_msgs--;
654 _log('>>', $msg);
655 $sth_insert_log->execute( $CHANNEL, 1, $NICK, $msg, 'now()' );
656 $args->{kernel}->post( $IRC_ALIAS => notice => $CHANNEL, $msg );
657 $updates++;
658 }
659 }
660
661 my $sql = qq{ update feeds set last_update = now(), polls = polls + 1 };
662 $sql .= qq{, updates = updates + $updates } if $updates;
663 $sql .= qq{where id = } . $args->{id};
664 eval { $dbh->do( $sql ) };
665
666 _log "RSS got $total items of which $updates new";
667
668 return $updates;
669 }
670
671 sub rss_fetch_all {
672 my $kernel = shift;
673 my $sql = qq{
674 select id, url, name
675 from feeds
676 where active is true
677 };
678 # limit to newer feeds only if we are not sending messages out
679 $sql .= qq{ and last_update + delay < now() } if $kernel;
680 my $sth = $dbh->prepare( $sql );
681 $sth->execute();
682 warn "# ",$sth->rows," active RSS feeds\n";
683 my $count = 0;
684 while (my $row = $sth->fetchrow_hashref) {
685 $row->{kernel} = $kernel if $kernel;
686 $count += rss_fetch( $row );
687 }
688 return "OK, fetched $count posts from " . $sth->rows . " feeds";
689 }
690
691
692 sub rss_check_updates {
693 my $kernel = shift;
694 my $last_t = $_rss->{last_poll} || time();
695 my $t = time();
696 if ( $t - $last_t > $rss_min_delay ) {
697 $_rss->{last_poll} = $t;
698 _log rss_fetch_all( $kernel );
699 }
700 }
701
702 # seed rss seen cache so we won't send out all items on startup
703 _log rss_fetch_all;
704
705 #
706 # POE handing part
707 #
708
709 my $ping; # ping stats
710
711 POE::Component::IRC->new($IRC_ALIAS);
712
713 POE::Session->create( inline_states => {
714 _start => sub {
715 $_[KERNEL]->post($IRC_ALIAS => register => 'all');
716 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
717 },
718 irc_255 => sub { # server is done blabbing
719 $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
720 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
721 },
722 irc_public => sub {
723 my $kernel = $_[KERNEL];
724 my $nick = (split /!/, $_[ARG0])[0];
725 my $channel = $_[ARG1]->[0];
726 my $msg = $_[ARG2];
727
728 save_message( channel => $channel, me => 0, nick => $nick, message => $msg);
729 meta( $nick, $channel, 'last-msg', $msg );
730 },
731 irc_ctcp_action => sub {
732 my $kernel = $_[KERNEL];
733 my $nick = (split /!/, $_[ARG0])[0];
734 my $channel = $_[ARG1]->[0];
735 my $msg = $_[ARG2];
736
737 save_message( channel => $channel, me => 1, nick => $nick, message => $msg);
738
739 if ( $use_twitter ) {
740 if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
741 my ($login,$passwd) = split(/\s+/,$twitter,2);
742 _log("sending twitter for $nick/$login on $channel ");
743 my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
744 $bot->update("<${channel}> $msg");
745 }
746 }
747
748 },
749 irc_ping => sub {
750 _log( "pong ", $_[ARG0] );
751 $ping->{ $_[ARG0] }++;
752 rss_check_updates( $_[KERNEL] );
753 },
754 irc_invite => sub {
755 my $kernel = $_[KERNEL];
756 my $nick = (split /!/, $_[ARG0])[0];
757 my $channel = $_[ARG1];
758
759 _log "invited to $channel by $nick";
760
761 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
762 $_[KERNEL]->post($IRC_ALIAS => join => $channel);
763
764 },
765 irc_msg => sub {
766 my $kernel = $_[KERNEL];
767 my $nick = (split /!/, $_[ARG0])[0];
768 my $msg = $_[ARG2];
769 my $channel = $_[ARG1]->[0];
770
771 my $res = "unknown command '$msg', try /msg $NICK help!";
772 my @out;
773
774 _log "<< $msg";
775
776 if ($msg =~ m/^help/i) {
777
778 $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
779
780 } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
781
782 _log ">> /msg $1 $2";
783 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
784 $res = '';
785
786 } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
787
788 my $nr = $1 || 10;
789
790 my $sth = $dbh->prepare(qq{
791 select
792 trim(both '_' from nick) as nick,
793 count(*) as count,
794 sum(length(message)) as len
795 from log
796 group by trim(both '_' from nick)
797 order by len desc,count desc
798 limit $nr
799 });
800 $sth->execute();
801 $res = "Top $nr users: ";
802 my @users;
803 while (my $row = $sth->fetchrow_hashref) {
804 push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
805 }
806 $res .= join(" | ", @users);
807 } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
808
809 my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
810
811 foreach my $res (get_from_log( limit => $limit )) {
812 _log "last: $res";
813 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
814 }
815
816 $res = '';
817
818 } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
819
820 my $what = $2;
821
822 foreach my $res (get_from_log(
823 limit => 20,
824 search => $what,
825 )) {
826 _log "search [$what]: $res";
827 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
828 }
829
830 $res = '';
831
832 } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
833
834 my ($what,$limit) = ($1,$2);
835 $limit ||= 100;
836
837 my $stat;
838
839 foreach my $res (get_from_log(
840 limit => $limit,
841 search => $what,
842 full_rows => 1,
843 )) {
844 while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
845 $stat->{vote}->{$1}++;
846 $stat->{from}->{ $res->{nick} }++;
847 }
848 }
849
850 my @nicks;
851 foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
852 push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
853 "(" . $stat->{from}->{$nick} . ")"
854 );
855 }
856
857 $res =
858 "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
859 " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
860 " from " . ( join(", ", @nicks) || 'nobody' );
861
862 $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
863
864 } elsif ($msg =~ m/^ping/) {
865 $res = "ping = " . dump( $ping );
866 } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
867 if ( ! defined( $1 ) ) {
868 my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
869 $sth->execute( $nick, $channel );
870 $res = "config for $nick on $channel";
871 while ( my ($n,$v) = $sth->fetchrow_array ) {
872 $res .= " | $n = $v";
873 }
874 } elsif ( ! $2 ) {
875 my $val = meta( $nick, $channel, $1 );
876 $res = "current $1 = " . ( $val ? $val : 'undefined' );
877 } else {
878 my $validate = {
879 'last-size' => qr/^\d+/,
880 'twitter' => qr/^\w+\s+\w+/,
881 };
882
883 my ( $op, $val ) = ( $1, $2 );
884
885 if ( my $regex = $validate->{$op} ) {
886 if ( $val =~ $regex ) {
887 meta( $nick, $channel, $op, $val );
888 $res = "saved $op = $val";
889 } else {
890 $res = "config option $op = $val doesn't validate against $regex";
891 }
892 } else {
893 $res = "config option $op doesn't exist";
894 }
895 }
896 } elsif ($msg =~ m/^rss-update/) {
897 $res = rss_fetch_all( $_[KERNEL] );
898 } elsif ($msg =~ m/^rss-clean/) {
899 $_rss = undef;
900 $dbh->do( qq{ update feeds set last_update = now() - delay } );
901 $res = "OK, cleaned RSS cache";
902 } elsif ($msg =~ m/^rss-list/) {
903 my $sth = $dbh->prepare(qq{ select url,name,last_update,active from feeds });
904 $sth->execute;
905 while (my @row = $sth->fetchrow_array) {
906 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, join(' | ',@row) );
907 }
908 $res = '';
909 } elsif ($msg =~ m!^rss-(add|remove|stop|start)\s+(http://\S+)\s*(.*)!) {
910 my $sql = {
911 add => qq{ insert into feeds (url,name) values (?,?) },
912 # remove => qq{ delete from feeds where url = ? and name = ? },
913 start => qq{ update feeds set active = true where url = ? },
914 stop => qq{ update feeds set active = false where url = ? },
915
916 };
917 if (my $q = $sql->{$1} ) {
918 my $sth = $dbh->prepare( $q );
919 my @data = ( $2 );
920 push @data, $3 if ( $q =~ s/\?//g == 2 );
921 warn "## $1 SQL $q with ",dump( @data ),"\n";
922 eval { $sth->execute( @data ) };
923 }
924
925 $res = "OK, RSS $1 : $2 - $3";
926 }
927
928 if ($res) {
929 _log ">> [$nick] $res";
930 $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
931 }
932
933 rss_check_updates( $_[KERNEL] );
934 },
935 irc_477 => sub {
936 _log "# irc_477: ",$_[ARG1];
937 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
938 },
939 irc_505 => sub {
940 _log "# irc_505: ",$_[ARG1];
941 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
942 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
943 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
944 },
945 irc_registered => sub {
946 _log "## registrated $NICK";
947 $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
948 },
949 irc_disconnected => sub {
950 _log "## disconnected, reconnecting again";
951 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
952 },
953 irc_socketerr => sub {
954 _log "## socket error... sleeping for $sleep_on_error seconds and retry";
955 sleep($sleep_on_error);
956 $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
957 },
958 # irc_433 => sub {
959 # print "# irc_433: ",$_[ARG1], "\n";
960 # warn "## indetify $NICK\n";
961 # $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
962 # },
963 _child => sub {},
964 _default => sub {
965 _log sprintf "sID:%s %s %s",
966 $_[SESSION]->ID, $_[ARG0],
967 ref($_[ARG1]) eq "ARRAY" ? join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] }) :
968 $_[ARG1] ? $_[ARG1] :
969 "";
970 0; # false for signals
971 },
972 },
973 );
974
975 # http server
976
977 my $httpd = POE::Component::Server::HTTP->new(
978 Port => $http_port,
979 PreHandler => {
980 '/' => sub {
981 $_[0]->header(Connection => 'close')
982 }
983 },
984 ContentHandler => { '/' => \&root_handler },
985 Headers => { Server => 'irc-logger' },
986 );
987
988 my $style = <<'_END_OF_STYLE_';
989 p { margin: 0; padding: 0.1em; }
990 .time, .channel { color: #808080; font-size: 60%; }
991 .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
992 .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
993 .message { color: #000000; font-size: 100%; }
994 .search { float: right; }
995 a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
996 a:hover.tag { border: 1px solid #eee }
997 hr { border: 1px dashed #ccc; height: 1px; clear: both; }
998 /*
999 .col-0 { background: #ffff66 }
1000 .col-1 { background: #a0ffff }
1001 .col-2 { background: #99ff99 }
1002 .col-3 { background: #ff9999 }
1003 .col-4 { background: #ff66ff }
1004 */
1005 .calendar { border: 1px solid red; width: 100%; }
1006 .month { border: 0px; width: 100%; }
1007 _END_OF_STYLE_
1008
1009 $max_color = 0;
1010
1011 my @cols = qw(
1012 #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
1013 #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
1014 #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
1015 #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
1016 #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
1017 );
1018
1019 foreach my $c (@cols) {
1020 $style .= ".col-${max_color} { background: $c }\n";
1021 $max_color++;
1022 }
1023 warn "defined $max_color colors for users...\n";
1024
1025 sub root_handler {
1026 my ($request, $response) = @_;
1027 $response->code(RC_OK);
1028
1029 # this doesn't seem to work, so moved to PreHandler
1030 #$response->header(Connection => 'close');
1031
1032 return RC_OK if $request->uri =~ m/favicon.ico$/;
1033
1034 my $q;
1035
1036 if ( $request->method eq 'POST' ) {
1037 $q = new CGI::Simple( $request->content );
1038 } elsif ( $request->uri =~ /\?(.+)$/ ) {
1039 $q = new CGI::Simple( $1 );
1040 } else {
1041 $q = new CGI::Simple;
1042 }
1043
1044 my $search = $q->param('search') || $q->param('grep') || '';
1045
1046 if ($request->url =~ m#/rss(?:/(tags|last-tag|follow.*)\w*(?:=(\d+))?)?#i) {
1047 my $show = lc($1);
1048 my $nr = $2;
1049
1050 my $type = 'RSS'; # Atom
1051
1052 $response->content_type( 'application/' . lc($type) . '+xml' );
1053
1054 my $html = '<!-- error -->';
1055 #warn "create $type feed from ",dump( @last_tags );
1056
1057 my $feed = XML::Feed->new( $type );
1058 $feed->link( $url );
1059
1060 if ( $show eq 'tags' ) {
1061 $nr ||= 50;
1062 $feed->title( "tags from $CHANNEL" );
1063 $feed->link( "$url/tags" );
1064 $feed->description( "tag cloud created from messages on channel $CHANNEL which have tags// in them" );
1065 my $feed_entry = XML::Feed::Entry->new($type);
1066 $feed_entry->title( "$nr tags from $CHANNEL" );
1067 $feed_entry->author( $NICK );
1068 $feed_entry->link( '/#tags' );
1069
1070 $feed_entry->content(
1071 qq{<![CDATA[<style type="text/css">}
1072 . $cloud->css
1073 . qq{</style>}
1074 . $cloud->html( $nr )
1075 . qq{]]>}
1076 );
1077 $feed->add_entry( $feed_entry );
1078
1079 } elsif ( $show eq 'last-tag' ) {
1080
1081 $nr ||= $last_x_tags;
1082 $nr = $last_x_tags if $nr > $last_x_tags;
1083
1084 $feed->title( "last $nr tagged messages from $CHANNEL" );
1085 $feed->description( "collects messages which have tags// in them" );
1086
1087 foreach my $m ( @last_tags ) {
1088 # warn dump( $m );
1089 #my $tags = join(' ', @{$m->{tags}} );
1090 my $feed_entry = XML::Feed::Entry->new($type);
1091 $feed_entry->title( $m->{nick} . '@' . $m->{time} );
1092 $feed_entry->author( $m->{nick} );
1093 $feed_entry->link( '/#' . $m->{id} );
1094 $feed_entry->issued( DateTime::Format::Flexible->build( $m->{time} ) );
1095
1096 my $message = $filter->{message}->( $m->{message} );
1097 $message .= "<br/>\n" unless $message =~ m!<(/p|br/?)>!;
1098 # warn "## message = $message\n";
1099
1100 #$feed_entry->summary(
1101 $feed_entry->content(
1102 "<![CDATA[$message]]>"
1103 );
1104 $feed_entry->category( join(', ', @{$m->{tags}}) );
1105 $feed->add_entry( $feed_entry );
1106
1107 $nr--;
1108 last if $nr <= 0;
1109
1110 }
1111
1112 } elsif ( $show =~ m/^follow/ ) {
1113
1114 $feed->title( "Feeds which this bot follows" );
1115
1116 my $sth = $dbh->prepare( qq{ select * from feeds order by last_update desc } );
1117 $sth->execute;
1118 while (my $row = $sth->fetchrow_hashref) {
1119 my $feed_entry = XML::Feed::Entry->new($type);
1120 $feed_entry->title( $row->{name} );
1121 $feed_entry->link( $row->{url} );
1122 $feed_entry->issued( DateTime::Format::Flexible->build( $row->{last_update} ) );
1123 $feed_entry->content(
1124 '<![CDATA[<pre>' . dump( $row ) . '</pre>]]>'
1125 );
1126 $feed->add_entry( $feed_entry );
1127 }
1128
1129 } else {
1130 _log "unknown rss request ",$request->url;
1131 return RC_DENY;
1132 }
1133
1134 $response->content( $feed->as_xml );
1135 return RC_OK;
1136 }
1137
1138 if ( $@ ) {
1139 warn "$@";
1140 }
1141
1142 $response->content_type("text/html; charset=UTF-8");
1143
1144 my $html =
1145 qq{<html><head><title>$NICK</title><style type="text/css">$style}
1146 . $cloud->css
1147 . qq{</style></head><body>}
1148 . qq{
1149 <form method="post" class="search" action="/">
1150 <input type="text" name="search" value="$search" size="10">
1151 <input type="submit" value="search">
1152 </form>
1153 }
1154 . $cloud->html(500)
1155 . qq{<p>};
1156
1157 if ($request->url =~ m#/tags?#) {
1158 # nop
1159 } elsif ($request->url =~ m#/history#) {
1160 my $sth = $dbh->prepare(qq{
1161 select date(time) as date,count(*) as nr,sum(length(message)) as len
1162 from log
1163 group by date(time)
1164 order by date(time) desc
1165 });
1166 $sth->execute();
1167 my ($l_yyyy,$l_mm) = (0,0);
1168 $html .= qq{<table class="calendar"><tr>};
1169 my $cal;
1170 my $ord = 0;
1171 while (my $row = $sth->fetchrow_hashref) {
1172 # this is probably PostgreSQL specific, expects ISO date
1173 my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
1174 if ($yyyy != $l_yyyy || $mm != $l_mm) {
1175 if ( $cal ) {
1176 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
1177 $ord++;
1178 $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
1179 }
1180 $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
1181 $cal->border(1);
1182 $cal->width('30%');
1183 $cal->cellheight('5em');
1184 $cal->tableclass('month');
1185 #$cal->cellclass('day');
1186 $cal->sunday('SUN');
1187 $cal->saturday('SAT');
1188 $cal->weekdays('MON','TUE','WED','THU','FRI');
1189 ($l_yyyy,$l_mm) = ($yyyy,$mm);
1190 }
1191 $cal->setcontent($dd, qq[
1192 <a href="$url?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
1193 ]) if $cal;
1194
1195 }
1196 $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
1197
1198 } else {
1199 $html .= join("</p><p>",
1200 get_from_log(
1201 limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
1202 search => $search || undef,
1203 tag => $q->param('tag') || undef,
1204 date => $q->param('date') || undef,
1205 fmt => {
1206 date => sub {
1207 my $date = shift || return;
1208 qq{<hr/><div class="date"><a href="$url?date=$date">$date</a></div>};
1209 },
1210 time => '<span class="time">%s</span> ',
1211 time_channel => '<span class="channel">%s %s</span> ',
1212 nick => '%s:&nbsp;',
1213 me_nick => '***%s&nbsp;',
1214 message => '<span class="message">%s</span>',
1215 },
1216 filter => $filter,
1217 )
1218 );
1219 }
1220
1221 $html .= qq{</p>
1222 <hr/>
1223 <p>See <a href="/history">history</a> of all messages.</p>
1224 </body></html>};
1225
1226 $response->content( $html );
1227 warn "<< ", $request->method, " ", $request->uri, " created ", length($html), " bytes\n";
1228 return RC_OK;
1229 }
1230
1231 POE::Kernel->run;

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26