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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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