/[irc-logger]/trunk/bin/irc-logger.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

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

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

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