/[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 5 by dpavlin, Mon Feb 27 12:10:07 2006 UTC trunk/bin/irc-logger.pl revision 69 by dpavlin, Fri Dec 7 12:51: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 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 60  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            eval { $sth->execute( @args ) };
312            return if $@;
313    
314            my $last_row = {
315                    date => '',
316                    time => '',
317                    channel => '',
318                    nick => '',
319            };
320    
321            my @rows;
322    
323            while (my $row = $sth->fetchrow_hashref) {
324                    unshift @rows, $row;
325            }
326    
327            # normalize nick names
328            map {
329                    $_->{nick} =~ s/^_*(.*?)_*$/$1/
330            } @rows;
331    
332            return @rows if ($args->{full_rows});
333    
334            my @msgs = (
335                    "Showing " . ($#rows + 1) . " messages..."
336            );
337    
338            if ($context) {
339                    my @ids = @rows;
340                    @rows = ();
341    
342                    my $last_to = 0;
343    
344                    my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
345                    foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
346                            my $id = $row_id->{id} || die "can't find id in row";
347            
348                            my ($from, $to) = ($id - $context, $id + $context);
349                            $from = $last_to if ($from < $last_to);
350                            $last_to = $to;
351                            $sth->execute( $from, $to );
352    
353                            #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
354    
355                            while (my $row = $sth->fetchrow_hashref) {
356                                    push @rows, $row;
357                            }
358    
359                    }
360            }
361    
362            # sprintf which can take coderef as first parametar
363            sub cr_sprintf {
364                    my $fmt = shift || return;
365                    if (ref($fmt) eq 'CODE') {
366                            $fmt->(@_);
367                    } else {
368                            sprintf($fmt, @_);
369                    }
370            }
371    
372            foreach my $row (@rows) {
373    
374                    $row->{time} =~ s#\.\d+##;
375    
376                    my $msg = '';
377    
378                    $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
379                    my $t = $row->{time};
380    
381                    if ($last_row->{channel} ne $row->{channel}) {
382                            $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
383                    } else {
384                            $msg .= cr_sprintf($args->{fmt}->{time}, $t);
385                    }
386    
387                    my $append = 1;
388    
389                    my $nick = $row->{nick};
390    #               if ($nick =~ s/^_*(.*?)_*$/$1/) {
391    #                       $row->{nick} = $nick;
392    #               }
393    
394                    if ($last_row->{nick} ne $nick) {
395                            # obfu way to find format for me_nick if needed or fallback to default
396                            my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
397                            $fmt ||= '%s';
398    
399                            $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
400    
401                            $msg .= cr_sprintf( $fmt, $nick );
402                            $append = 0;
403                    }
404    
405                    $args->{fmt}->{message} ||= '%s';
406                    if (ref($args->{filter}->{message}) eq 'CODE') {
407                            $msg .= cr_sprintf($args->{fmt}->{message},
408                                    $args->{filter}->{message}->(
409                                            $row->{message}
410                                    )
411                            );
412                    } else {
413                            $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
414                    }
415    
416                    if ($append && @msgs) {
417                            $msgs[$#msgs] .= " " . $msg;
418                    } else {
419                            push @msgs, $msg;
420                    }
421    
422                    $last_row = $row;
423            }
424    
425            return @msgs;
426    }
427    
428    # tags support
429    
430    my $cloud = HTML::TagCloud->new;
431    
432    =head2 add_tag
433    
434     add_tag( id => 42, message => 'irc message' );
435    
436    =cut
437    
438    sub add_tag {
439            my $arg = {@_};
440    
441            return unless ($arg->{id} && $arg->{message});
442    
443            my $m = $arg->{message};
444            from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
445    
446            while ($m =~ s#$tag_regex##s) {
447                    my $tag = $1;
448                    next if (! $tag || $tag =~ m/https?:/i);
449                    push @{ $tags->{$tag} }, $arg->{id};
450                    #warn "+tag $tag: $arg->{id}\n";
451                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
452            }
453    }
454    
455    =head2 seed_tags
456    
457    Read all tags from database and create in-memory cache for tags
458    
459    =cut
460    
461    sub seed_tags {
462            my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });
463            $sth->execute;
464            while (my $row = $sth->fetchrow_hashref) {
465                    add_tag( %$row );
466            }
467    
468            foreach my $tag (keys %$tags) {
469                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
470            }
471    }
472    
473    seed_tags;
474    
475    
476    =head2 save_message
477    
478      save_message(
479            channel => '#foobar',
480            me => 0,
481            nick => 'dpavlin',
482            msg => 'test message',
483            time => '2006-06-25 18:57:18',
484      );
485    
486    C<time> is optional, it will use C<< now() >> if it's not available.
487    
488    C<me> if not specified will be C<0> (not C</me> message)
489    
490    =cut
491    
492    sub save_message {
493            my $a = {@_};
494            $a->{me} ||= 0;
495            $a->{time} ||= strftime($TIMESTAMP,localtime());
496    
497            _log
498                    $a->{channel}, " ",
499                    $a->{me} ? "***" . $a->{nick} : "<" . $a->{nick} . ">",
500                    " " . $a->{msg};
501    
502            from_to($a->{msg}, 'UTF-8', $ENCODING);
503    
504            $sth->execute($a->{channel}, $a->{me}, $a->{nick}, $a->{msg}, $a->{time});
505            add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),
506                    message => $a->{msg});
507    }
508    
509    
510    if ($import_dircproxy) {
511            open(my $l, $import_dircproxy) || die "can't open $import_dircproxy: $!";
512            warn "importing $import_dircproxy...\n";
513            my $tz_offset = 1 * 60 * 60;    # TZ GMT+2
514            while(<$l>) {
515                    chomp;
516                    if (/^@(\d+)\s(\S+)\s(.+)$/) {
517                            my ($time, $nick, $msg) = ($1,$2,$3);
518    
519                            my $dt = DateTime->from_epoch( epoch => $time + $tz_offset );
520    
521                            my $me = 0;
522                            $me = 1 if ($nick =~ m/^\[\S+]/);
523                            $nick =~ s/^[\[<]([^!]+).*$/$1/;
524    
525                            $msg =~ s/^ACTION\s+// if ($me);
526    
527                            save_message(
528                                    channel => $CHANNEL,
529                                    me => $me,
530                                    nick => $nick,
531                                    msg => $msg,
532                                    time => $dt->ymd . " " . $dt->hms,
533                            ) if ($nick !~ m/^-/);
534    
535                    } else {
536                            _log "can't parse: $_";
537                    }
538            }
539            close($l);
540            warn "import over\n";
541            exit;
542    }
543    
544    
545    #
546    # POE handing part
547    #
548    
549  my $SKIPPING = 0;               # if skipping, how many we've done  my $SKIPPING = 0;               # if skipping, how many we've done
550  my $SEND_QUEUE;                 # cache  my $SEND_QUEUE;                 # cache
551    my $ping;                                               # ping stats
552    
553  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
554    
555  POE::Session->create  POE::Session->create( inline_states =>
   (inline_states =>  
556     {_start => sub {           {_start => sub {      
557        $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
558        $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
559      },      },
560      irc_255 => sub {            # server is done blabbing      irc_255 => sub {    # server is done blabbing
561        $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
562        $_[KERNEL]->post($IRC_ALIAS => join => '#logger');                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
563        $_[KERNEL]->yield("heartbeat"); # start heartbeat                  $_[KERNEL]->yield("heartbeat"); # start heartbeat
564  #      $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
565                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
566      },      },
567      irc_public => sub {      irc_public => sub {
568            my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
569            my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
570            my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
571            my $msg = $_[ARG2];                  my $msg = $_[ARG2];
572    
573            print "$channel: <$nick> $msg\n";                  save_message( channel => $channel, me => 0, nick => $nick, msg => $msg);
574            $sth->execute($channel, $nick, $msg);                  meta( $nick, $channel, 'last-msg', $msg );
575      },      },
576      (map      irc_ctcp_action => sub {
577       {                  my $kernel = $_[KERNEL];
578         ;"irc_$_" => sub { }}                  my $nick = (split /!/, $_[ARG0])[0];
579       qw(join                  my $channel = $_[ARG1]->[0];
580          ctcp_version                  my $msg = $_[ARG2];
581          connected snotice ctcp_action ping notice mode part quit  
582          001 002 003 004 005                  save_message( channel => $channel, me => 1, nick => $nick, msg => $msg);
583          250 251 252 253 254 265 266  
584          332 333 353 366 372 375 376                  if ( $use_twitter ) {
585                  477                          if ( my $twitter = meta( $nick, $NICK, 'twitter' ) ) {
586                  )),                                  my ($login,$passwd) = split(/\s+/,$twitter,2);
587                                    _log("sending twitter for $nick/$login on $channel ");
588                                    my $bot = Net::Twitter->new( username=>$login, password=>$passwd );
589                                    $bot->update("<${channel}> $msg");
590                            }
591                    }
592    
593        },
594            irc_ping => sub {
595                    warn "pong ", $_[ARG0], $/;
596                    $ping->{ $_[ARG0] }++;
597            },
598            irc_invite => sub {
599                    my $kernel = $_[KERNEL];
600                    my $nick = (split /!/, $_[ARG0])[0];
601                    my $channel = $_[ARG1];
602    
603                    warn "invited to $channel by $nick";
604    
605                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, "how nice of you to invite me to $channel, I'll be right there..." );
606                    $_[KERNEL]->post($IRC_ALIAS => join => $channel);
607    
608            },
609            irc_msg => sub {
610                    my $kernel = $_[KERNEL];
611                    my $nick = (split /!/, $_[ARG0])[0];
612                    my $msg = $_[ARG2];
613                    my $channel = $_[ARG1]->[0];
614                    from_to($msg, 'UTF-8', $ENCODING);
615    
616                    my $res = "unknown command '$msg', try /msg $NICK help!";
617                    my @out;
618    
619                    _log "<< $msg";
620    
621                    if ($msg =~ m/^help/i) {
622    
623                            $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
624    
625                    } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
626    
627                            _log ">> /msg $1 $2";
628                            $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
629                            $res = '';
630    
631                    } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
632    
633                            my $nr = $1 || 10;
634    
635                            my $sth = $dbh->prepare(qq{
636                                    select
637                                            trim(both '_' from nick) as nick,
638                                            count(*) as count,
639                                            sum(length(message)) as len
640                                    from log
641                                    group by trim(both '_' from nick)
642                                    order by len desc,count desc
643                                    limit $nr
644                            });
645                            $sth->execute();
646                            $res = "Top $nr users: ";
647                            my @users;
648                            while (my $row = $sth->fetchrow_hashref) {
649                                    push @users,$row->{nick} . ': ' . $row->{count} . '/' . $row->{len} . '=' . sprintf("%.2f", $row->{len}/$row->{count});
650                            }
651                            $res .= join(" | ", @users);
652                    } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
653    
654                            my $limit = $1 || meta( $nick, $channel, 'last-size' ) || 10;
655    
656                            foreach my $res (get_from_log( limit => $limit )) {
657                                    _log "last: $res";
658                                    from_to($res, $ENCODING, 'UTF-8');
659                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
660                            }
661    
662                            $res = '';
663    
664                    } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
665    
666                            my $what = $2;
667    
668                            foreach my $res (get_from_log(
669                                            limit => 20,
670                                            search => $what,
671                                    )) {
672                                    _log "search [$what]: $res";
673                                    from_to($res, $ENCODING, 'UTF-8');
674                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
675                            }
676    
677                            $res = '';
678    
679                    } elsif ($msg =~ m/^(?:count|poll)\s+(.*)(?:\s+(\d+))?\s*$/i) {
680    
681                            my ($what,$limit) = ($1,$2);
682                            $limit ||= 100;
683    
684                            my $stat;
685    
686                            foreach my $res (get_from_log(
687                                            limit => $limit,
688                                            search => $what,
689                                            full_rows => 1,
690                                    )) {
691                                    while ($res->{message} =~ s/\Q$what\E(\+|\-)//) {
692                                            $stat->{vote}->{$1}++;
693                                            $stat->{from}->{ $res->{nick} }++;
694                                    }
695                            }
696    
697                            my @nicks;
698                            foreach my $nick (sort { $stat->{from}->{$a} <=> $stat->{from}->{$b} } keys %{ $stat->{from} }) {
699                                    push @nicks, $nick . ( $stat->{from}->{$nick} == 1 ? '' :
700                                            "(" . $stat->{from}->{$nick} . ")"
701                                    );
702                            }
703    
704                            $res =
705                                    "$what ++ " . ( $stat->{vote}->{'+'} || 0 ) .
706                                    " : " . ( $stat->{vote}->{'-'} || 0 ) . " --" .
707                                    " from " . ( join(", ", @nicks) || 'nobody' );
708    
709                            $_[KERNEL]->post( $IRC_ALIAS => notice => $nick, $res );
710    
711                    } elsif ($msg =~ m/^ping/) {
712                            $res = "ping = " . dump( $ping );
713                    } elsif ($msg =~ m/^conf(?:ig)*\s*(last-size|twitter)*\s*(.*)/) {
714                            if ( ! defined( $1 ) ) {
715                                    my $sth = $dbh->prepare(qq{ select name,value,changed from meta where nick = ? and channel = ? });
716                                    $sth->execute( $nick, $channel );
717                                    $res = "config for $nick on $channel";
718                                    while ( my ($n,$v) = $sth->fetchrow_array ) {
719                                            $res .= " | $n = $v";
720                                    }
721                            } elsif ( ! $2 ) {
722                                    my $val = meta( $nick, $channel, $1 );
723                                    $res = "current $1 = " . ( $val ? $val : 'undefined' );
724                            } else {
725                                    my $validate = {
726                                            'last-size' => qr/^\d+/,
727                                            'twitter' => qr/^\w+\s+\w+/,
728                                    };
729    
730                                    my ( $op, $val ) = ( $1, $2 );
731    
732                                    if ( my $regex = $validate->{$op} ) {
733                                            if ( $val =~ $regex ) {
734                                                    meta( $nick, $channel, $op, $val );
735                                                    $res = "saved $op = $val";
736                                            } else {
737                                                    $res = "config option $op = $val doesn't validate against $regex";
738                                            }
739                                    } else {
740                                            $res = "config option $op doesn't exist";
741                                    }
742                            }
743                    }
744    
745                    if ($res) {
746                            _log ">> [$nick] $res";
747                            from_to($res, $ENCODING, 'UTF-8');
748                            $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
749                    }
750    
751            },
752            irc_477 => sub {
753                    _log "# irc_477: ",$_[ARG1];
754                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
755            },
756            irc_505 => sub {
757                    _log "# irc_505: ",$_[ARG1];
758                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
759    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
760    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
761            },
762            irc_registered => sub {
763                    _log "## registrated $NICK";
764                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
765            },
766            irc_disconnected => sub {
767                    _log "## disconnected, reconnecting again";
768                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
769            },
770            irc_socketerr => sub {
771                    _log "## socket error... sleeping for $sleep_on_error seconds and retry";
772                    sleep($sleep_on_error);
773                    $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
774            },
775    #       irc_433 => sub {
776    #               print "# irc_433: ",$_[ARG1], "\n";
777    #               warn "## indetify $NICK\n";
778    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
779    #       },
780      _child => sub {},      _child => sub {},
781      _default => sub {      _default => sub {
782        printf "%s: session %s caught an unhandled %s event.\n",                  _log sprintf "sID:%s %s %s",
783          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          $_[SESSION]->ID, $_[ARG0],
784        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
785          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
786                            "";
787        0;                        # false for signals        0;                        # false for signals
788      },      },
789      my_add => sub {      my_add => sub {
# Line 180  POE::Session->create Line 849  POE::Session->create
849     },     },
850    );    );
851    
852    # http server
853    
854    my $httpd = POE::Component::Server::HTTP->new(
855            Port => $NICK =~ m/-dev/ ? 8001 : 8000,
856            ContentHandler => { '/' => \&root_handler },
857            Headers        => { Server => 'irc-logger' },
858    );
859    
860    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
861    my $escape_re  = join '|' => keys %escape;
862    
863    my $style = <<'_END_OF_STYLE_';
864    p { margin: 0; padding: 0.1em; }
865    .time, .channel { color: #808080; font-size: 60%; }
866    .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
867    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
868    .message { color: #000000; font-size: 100%; }
869    .search { float: right; }
870    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
871    a:hover.tag { border: 1px solid #eee }
872    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
873    /*
874    .col-0 { background: #ffff66 }
875    .col-1 { background: #a0ffff }
876    .col-2 { background: #99ff99 }
877    .col-3 { background: #ff9999 }
878    .col-4 { background: #ff66ff }
879    */
880    .calendar { border: 1px solid red; width: 100%; }
881    .month { border: 0px; width: 100%; }
882    _END_OF_STYLE_
883    
884    my $max_color = 4;
885    
886    my @cols = qw(
887            #ffcccc #ccffe6 #ccccff #e6ccff #ffccff #ffcce6 #ff9999 #ffcc99 #ffff99
888            #ccff99 #99ff99 #99ffcc #99ccff #9999ff #cc99ff #ff6666 #ffb366 #ffff66
889            #66ff66 #66ffb3 #66b3ff #6666ff #ff3333 #33ff33 #3399ff #3333ff #ff3399
890            #a0a0a0 #ff0000 #ffff00 #80ff00 #0000ff #8000ff #ff00ff #ff0080 #994d00
891            #999900 #009900 #cc0066 #c0c0c0 #ccff99 #99ff33 #808080 #660033 #ffffff
892    );
893    
894    $max_color = 0;
895    foreach my $c (@cols) {
896            $style .= ".col-${max_color} { background: $c }\n";
897            $max_color++;
898    }
899    warn "defined $max_color colors for users...\n";
900    
901    my %nick_enumerator;
902    
903    sub root_handler {
904            my ($request, $response) = @_;
905            $response->code(RC_OK);
906            $response->content_type("text/html; charset=$ENCODING");
907    
908            my $q;
909    
910            if ( $request->method eq 'POST' ) {
911                    $q = new CGI::Simple( $request->content );
912            } elsif ( $request->uri =~ /\?(.+)$/ ) {
913                    $q = new CGI::Simple( $1 );
914            } else {
915                    $q = new CGI::Simple;
916            }
917    
918            my $search = $q->param('search') || $q->param('grep') || '';
919    
920            my $html =
921                    qq{<html><head><title>$NICK</title><style type="text/css">$style} .
922                    $cloud->css .
923                    qq{</style></head><body>} .
924                    qq{
925                    <form method="post" class="search" action="/">
926                    <input type="text" name="search" value="$search" size="10">
927                    <input type="submit" value="search">
928                    </form>
929                    } .
930                    $cloud->html(500) .
931                    qq{<p>};
932            if ($request->url =~ m#/history#) {
933                    my $sth = $dbh->prepare(qq{
934                            select date(time) as date,count(*) as nr,sum(length(message)) as len
935                                    from log
936                                    group by date(time)
937                                    order by date(time) desc
938                    });
939                    $sth->execute();
940                    my ($l_yyyy,$l_mm) = (0,0);
941                    $html .= qq{<table class="calendar"><tr>};
942                    my $cal;
943                    my $ord = 0;
944                    while (my $row = $sth->fetchrow_hashref) {
945                            # this is probably PostgreSQL specific, expects ISO date
946                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
947                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
948                                    if ( $cal ) {
949                                            $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td>};
950                                            $ord++;
951                                            $html .= qq{</tr><tr>} if ( $ord % 3 == 0 );
952                                    }
953                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
954                                    $cal->border(1);
955                                    $cal->width('30%');
956                                    $cal->cellheight('5em');
957                                    $cal->tableclass('month');
958                                    #$cal->cellclass('day');
959                                    $cal->sunday('SUN');
960                                    $cal->saturday('SAT');
961                                    $cal->weekdays('MON','TUE','WED','THU','FRI');
962                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
963                            }
964                            $cal->setcontent($dd, qq{
965                                    <a href="/?date=$row->{date}">$row->{nr}</a><br/>$row->{len}
966                            });
967                            
968                    }
969                    $html .= qq{<td valign="top">} . $cal->as_HTML() . qq{</td></tr></table>};
970    
971            } else {
972                    $html .= join("</p><p>",
973                            get_from_log(
974                                    limit => ( $q->param('last') || $q->param('date') ) ? undef : 100,
975                                    search => $search || undef,
976                                    tag => $q->param('tag') || undef,
977                                    date => $q->param('date') || undef,
978                                    fmt => {
979                                            date => sub {
980                                                    my $date = shift || return;
981                                                    qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div>};
982                                            },
983                                            time => '<span class="time">%s</span> ',
984                                            time_channel => '<span class="channel">%s %s</span> ',
985                                            nick => '%s:&nbsp;',
986                                            me_nick => '***%s&nbsp;',
987                                            message => '<span class="message">%s</span>',
988                                    },
989                                    filter => {
990                                            message => sub {
991                                                    my $m = shift || return;
992    
993                                                    # protect HTML from wiki modifications
994                                                    sub e {
995                                                            my $t = shift;
996                                                            return 'uri_unescape{' . uri_escape($t) . '}';
997                                                    }
998    
999                                                    $m =~ s/($escape_re)/$escape{$1}/gs;
1000                                                    $m =~ s#($RE{URI}{HTTP})#e(qq{<a href="$1">$1</a>})#egs;
1001                                                    $m =~ s#$tag_regex#e(qq{<a href="?tag=$1" class="tag">$1</a>})#egs;
1002                                                    $m =~ s#\*(\w+)\*#<b>$1</b>#gs;
1003                                                    $m =~ s#_(\w+)_#<u>$1</u>#gs;
1004                                                    $m =~ s#\/(\w+)\/#<i>$1</i>#gs;
1005    
1006                                                    $m =~ s#uri_unescape{([^}]+)}#uri_unescape($1)#egs;
1007                                                    return $m;
1008                                            },
1009                                            nick => sub {
1010                                                    my $n = shift || return;
1011                                                    if (! $nick_enumerator{$n})  {
1012                                                            my $max = scalar keys %nick_enumerator;
1013                                                            $nick_enumerator{$n} = $max + 1;
1014                                                    }
1015                                                    return '<span class="nick col-' .
1016                                                            ( $nick_enumerator{$n} % $max_color ) .
1017                                                            '">' . $n . '</span>';
1018                                            },
1019                                    },
1020                            )
1021                    );
1022            }
1023    
1024            $html .= qq{</p>
1025            <hr/>
1026            <p>See <a href="/history">history</a> of all messages.</p>
1027            </body></html>};
1028    
1029            $response->content( $html );
1030            return RC_OK;
1031    }
1032    
1033  POE::Kernel->run;  POE::Kernel->run;
Legend:
Removed from v.5  
changed lines
  Added in v.69
  ViewVC Help
Powered by ViewVC 1.1.26