/[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

Annotation of /trunk/bin/irc-logger.pl

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:executable *

  ViewVC Help
Powered by ViewVC 1.1.26