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