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