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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26