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