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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26