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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26