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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26