/[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

revision 5 by dpavlin, Mon Feb 27 12:10:07 2006 UTC revision 31 by dpavlin, Sat Jun 17 17:23:26 2006 UTC
# Line 22  my $NICK = 'irc-logger'; Line 22  my $NICK = 'irc-logger';
22  my $CONNECT =  my $CONNECT =
23    {Server => 'irc.freenode.net',    {Server => 'irc.freenode.net',
24     Nick => $NICK,     Nick => $NICK,
25     Ircname => 'logger: ask dpavlin@rot13.org'     Ircname => "try /msg $NICK help",
26    };    };
27  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
28  my $IRC_ALIAS = "log";  my $IRC_ALIAS = "log";
# Line 33  my %FOLLOWS = Line 33  my %FOLLOWS =
33     ERROR => "/var/log/apache/error.log",     ERROR => "/var/log/apache/error.log",
34    );    );
35    
36  my $DSN = 'DBI:Pg:dbname=irc-logger';  my $DSN = 'DBI:Pg:dbname=' . $NICK;
37    
38    my $ENCODING = 'ISO-8859-2';
39    
40  ## END CONFIG  ## END CONFIG
41    
42    
43    
44  use POE qw(Component::IRC Wheel::FollowTail);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
45    use HTTP::Status;
46  use DBI;  use DBI;
47    use Encode qw/from_to is_utf8/;
48    use Regexp::Common qw /URI/;
49    use CGI::Simple;
50    use HTML::TagCloud;
51    
52  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
53    
54  =for SQL schema  eval {
55            $dbh->do(qq{ select count(*) from log });
56    };
57    
58    if ($@) {
59            warn "creating database table in $DSN\n";
60            $dbh->do(<<'_SQL_SCHEMA_');
61    
 $dbh->do(qq{  
62  create table log (  create table log (
63          id serial,          id serial,
64          time timestamp default now(),          time timestamp default now(),
65          channel text not null,          channel text not null,
66            me boolean default false,
67          nick text not null,          nick text not null,
68          message text not null,          message text not null,
69          primary key(id)          primary key(id)
# Line 61  create index log_time on log(time); Line 73  create index log_time on log(time);
73  create index log_channel on log(channel);  create index log_channel on log(channel);
74  create index log_nick on log(nick);  create index log_nick on log(nick);
75    
76  });  _SQL_SCHEMA_
77    }
 =cut  
78    
79  my $sth = $dbh->prepare(qq{  my $sth = $dbh->prepare(qq{
80  insert into log  insert into log
81          (channel, nick, message)          (channel, me, nick, message)
82  values (?,?,?)  values (?,?,?,?)
83  });  });
84    
85    my $tags;
86    my $tag_regex = '\b([\w-_]+)//';
87    
88    =head2 get_from_log
89    
90     my @messages = get_from_log(
91            limit => 42,
92            search => '%what to stuff in ilike%',
93            fmt => {
94                    time => '{%s} ',
95                    time_channel => '{%s %s} ',
96                    nick => '%s: ',
97                    me_nick => '***%s ',
98                    message => '%s',
99            },
100            filter => {
101                    message => sub {
102                            # modify message content
103                            return shift;
104                    }
105            },
106            context => 5,
107     );
108    
109    Order is important. Fields are first passed through C<filter> (if available) and
110    then throgh C<< sprintf($fmt->{message}, $message >> if available.
111    
112    C<context> defines number of messages around each search hit for display.
113    
114    =cut
115    
116    sub get_from_log {
117            my $args = {@_};
118    
119            $args->{limit} ||= 10;
120    
121            $args->{fmt} ||= {
122                    date => '[%s] ',
123                    time => '{%s} ',
124                    time_channel => '{%s %s} ',
125                    nick => '%s: ',
126                    me_nick => '***%s ',
127                    message => '%s',
128            };
129    
130            my $sql_message = qq{
131                    select
132                            time::date as date,
133                            time::time as time,
134                            channel,
135                            me,
136                            nick,
137                            message
138                    from log
139            };
140    
141            my $sql_context = qq{
142                    select
143                            id
144                    from log
145            };
146    
147            my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
148    
149            my $sql = $context ? $sql_context : $sql_message;
150    
151            $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});
152            $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });
153            $sql .= " order by log.time desc";
154            $sql .= " limit " . $args->{limit};
155    
156            my $sth = $dbh->prepare( $sql );
157            if (my $search = $args->{search}) {
158                    $search =~ s/^\s+//;
159                    $search =~ s/\s+$//;
160                    $sth->execute( ( '%' . $search . '%' ) x 2 );
161                    warn "search for '$search' returned ", $sth->rows, " results ", $context || '', "\n";
162            } elsif (my $tag = $args->{tag}) {
163                    $sth->execute();
164                    warn "tag '$tag' returned ", $sth->rows, " results ", $context || '', "\n";
165            } else {
166                    $sth->execute();
167            }
168            my $last_row = {
169                    date => '',
170                    time => '',
171                    channel => '',
172                    nick => '',
173            };
174    
175            my @rows;
176    
177            while (my $row = $sth->fetchrow_hashref) {
178                    unshift @rows, $row;
179            }
180    
181            my @msgs = (
182                    "Showing " . ($#rows + 1) . " messages..."
183            );
184    
185            if ($context) {
186                    my @ids = @rows;
187                    @rows = ();
188    
189                    my $last_to = 0;
190    
191                    my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
192                    foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
193                            my $id = $row_id->{id} || die "can't find id in row";
194            
195                            my ($from, $to) = ($id - $context, $id + $context);
196                            $from = $last_to if ($from < $last_to);
197                            $last_to = $to;
198                            $sth->execute( $from, $to );
199    
200                            #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
201    
202                            while (my $row = $sth->fetchrow_hashref) {
203                                    push @rows, $row;
204                            }
205    
206                    }
207            }
208    
209            foreach my $row (@rows) {
210    
211                    $row->{time} =~ s#\.\d+##;
212    
213                    my $msg = '';
214    
215                    $msg = sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
216                    my $t = $row->{time};
217    
218                    if ($last_row->{channel} ne $row->{channel}) {
219                            $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
220                    } else {
221                            $msg .= sprintf($args->{fmt}->{time}, $t);
222                    }
223    
224                    my $append = 1;
225    
226                    my $nick = $row->{nick};
227                    if ($nick =~ s/^_*(.*?)_*$/$1/) {
228                            $row->{nick} = $nick;
229                    }
230    
231                    if ($last_row->{nick} ne $nick) {
232                            # obfu way to find format for me_nick if needed or fallback to default
233                            my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
234                            $fmt ||= '%s';
235    
236                            $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
237    
238                            $msg .= sprintf( $fmt, $nick );
239                            $append = 0;
240                    }
241    
242                    $args->{fmt}->{message} ||= '%s';
243                    if (ref($args->{filter}->{message}) eq 'CODE') {
244                            $msg .= sprintf($args->{fmt}->{message},
245                                    $args->{filter}->{message}->(
246                                            $row->{message}
247                                    )
248                            );
249                    } else {
250                            $msg .= sprintf($args->{fmt}->{message}, $row->{message});
251                    }
252    
253                    if ($append && @msgs) {
254                            $msgs[$#msgs] .= " " . $msg;
255                    } else {
256                            push @msgs, $msg;
257                    }
258    
259                    $last_row = $row;
260            }
261    
262            return @msgs;
263    }
264    
265    
266  my $SKIPPING = 0;               # if skipping, how many we've done  my $SKIPPING = 0;               # if skipping, how many we've done
267  my $SEND_QUEUE;                 # cache  my $SEND_QUEUE;                 # cache
# Line 80  POE::Component::IRC->new($IRC_ALIAS); Line 271  POE::Component::IRC->new($IRC_ALIAS);
271  POE::Session->create  POE::Session->create
272    (inline_states =>    (inline_states =>
273     {_start => sub {           {_start => sub {      
274        $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
275        $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
276      },      },
277      irc_255 => sub {            # server is done blabbing      irc_255 => sub {    # server is done blabbing
278        $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
279        $_[KERNEL]->post($IRC_ALIAS => join => '#logger');                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
280        $_[KERNEL]->yield("heartbeat"); # start heartbeat                  $_[KERNEL]->yield("heartbeat"); # start heartbeat
281  #      $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
282                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
283      },      },
284      irc_public => sub {      irc_public => sub {
285            my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
286            my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
287            my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
288            my $msg = $_[ARG2];                  my $msg = $_[ARG2];
289    
290            print "$channel: <$nick> $msg\n";                  from_to($msg, 'UTF-8', $ENCODING);
291            $sth->execute($channel, $nick, $msg);  
292                    print "$channel: <$nick> $msg\n";
293                    $sth->execute($channel, 0, $nick, $msg);
294                    add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),
295                            message => $msg);
296        },
297        irc_ctcp_action => sub {
298                    my $kernel = $_[KERNEL];
299                    my $nick = (split /!/, $_[ARG0])[0];
300                    my $channel = $_[ARG1]->[0];
301                    my $msg = $_[ARG2];
302    
303                    from_to($msg, 'UTF-8', $ENCODING);
304    
305                    print "$channel ***$nick $msg\n";
306                    $sth->execute($channel, 1, $nick, $msg);
307                    add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),
308                            message => $msg);
309      },      },
310            irc_msg => sub {
311                    my $kernel = $_[KERNEL];
312                    my $nick = (split /!/, $_[ARG0])[0];
313                    my $msg = $_[ARG2];
314                    from_to($msg, 'UTF-8', $ENCODING);
315    
316                    my $res = "unknown command '$msg', try /msg $NICK help!";
317                    my @out;
318    
319                    print "<< $msg\n";
320    
321                    if ($msg =~ m/^help/i) {
322    
323                            $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
324    
325                    } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
326    
327                            print ">> /msg $1 $2\n";
328                            $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
329                            $res = '';
330    
331                    } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
332    
333                            my $nr = $1 || 10;
334    
335                            my $sth = $dbh->prepare(qq{
336                                    select nick,count(*) from log group by nick order by count desc limit $nr
337                            });
338                            $sth->execute();
339                            $res = "Top $nr users: ";
340                            my @users;
341                            while (my $row = $sth->fetchrow_hashref) {
342                                    push @users,$row->{nick} . ': ' . $row->{count};
343                            }
344                            $res .= join(" | ", @users);
345                    } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
346    
347                            foreach my $res (get_from_log( limit => $1 )) {
348                                    print "last: $res\n";
349                                    from_to($res, $ENCODING, 'UTF-8');
350                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
351                            }
352    
353                            $res = '';
354    
355                    } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
356    
357                            my $what = $2;
358    
359                            foreach my $res (get_from_log(
360                                            limit => 20,
361                                            search => $what,
362                                    )) {
363                                    print "search [$what]: $res\n";
364                                    from_to($res, $ENCODING, 'UTF-8');
365                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
366                            }
367    
368                            $res = '';
369    
370                    }
371    
372                    if ($res) {
373                            print ">> [$nick] $res\n";
374                            from_to($res, $ENCODING, 'UTF-8');
375                            $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
376                    }
377    
378            },
379            irc_477 => sub {
380                    print "# irc_477: ",$_[ARG1], "\n";
381                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
382            },
383            irc_505 => sub {
384                    print "# irc_505: ",$_[ARG1], "\n";
385                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
386    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
387    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
388            },
389            irc_registered => sub {
390                    warn "## indetify $NICK\n";
391                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
392            },
393    #       irc_433 => sub {
394    #               print "# irc_433: ",$_[ARG1], "\n";
395    #               warn "## indetify $NICK\n";
396    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
397    #       },
398            irc_372 => sub {
399                    print "MOTD: ", $_[ARG1], "\n";
400            },
401            irc_snotice => sub {
402                    print "(server notice): ", $_[ARG0], "\n";
403            },
404      (map      (map
405       {       {
406         ;"irc_$_" => sub { }}         ;"irc_$_" => sub { }}
407       qw(join       qw(
         ctcp_version  
         connected snotice ctcp_action ping notice mode part quit  
         001 002 003 004 005  
         250 251 252 253 254 265 266  
         332 333 353 366 372 375 376  
                 477  
408                  )),                  )),
409    #       join
410    #       ctcp_version
411    #       connected snotice ctcp_action ping notice mode part quit
412    #       001 002 003 004 005
413    #       250 251 252 253 254 265 266
414    #       332 333 353 366 372 375 376
415    #       477
416      _child => sub {},      _child => sub {},
417      _default => sub {      _default => sub {
418        printf "%s: session %s caught an unhandled %s event.\n",        printf "%s: session %s caught an unhandled %s event.\n",
# Line 180  POE::Session->create Line 484  POE::Session->create
484     },     },
485    );    );
486    
487    # tags support
488    
489    my $cloud = HTML::TagCloud->new;
490    
491    =head2 add_tag
492    
493     add_tag( id => 42, message => 'irc message' );
494    
495    =cut
496    
497    sub add_tag {
498            my $arg = {@_};
499    
500            return unless ($arg->{id} && $arg->{message});
501    
502            my $m = $arg->{message};
503            from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
504    
505            while ($m =~ s#$tag_regex##s) {
506                    my $tag = $1;
507                    next if (! $tag || $tag =~ m/https?:/i);
508                    push @{ $tags->{$tag} }, $arg->{id};
509                    warn "+tag $tag: $arg->{id}\n";
510            }
511    }
512    
513    =head2 seed_tags
514    
515    Read all tags from database and create in-memory cache for tags
516    
517    =cut
518    
519    sub seed_tags {
520            my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });
521            $sth->execute;
522            while (my $row = $sth->fetchrow_hashref) {
523                    add_tag( %$row );
524            }
525    
526            foreach my $tag (keys %$tags) {
527                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
528            }
529    }
530    
531    seed_tags;
532    
533    # http server
534    
535    my $httpd = POE::Component::Server::HTTP->new(
536            Port => $NICK =~ m/-dev/ ? 8001 : 8000,
537            ContentHandler => { '/' => \&root_handler },
538            Headers        => { Server => 'irc-logger' },
539    );
540    
541    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
542    my $escape_re  = join '|' => keys %escape;
543    
544    my $style = <<'_END_OF_STYLE_';
545    p { margin: 0; padding: 0.1em; }
546    .time, .channel { color: #808080; font-size: 60%; }
547    .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
548    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
549    .message { color: #000000; font-size: 100%; }
550    .search { float: right; }
551    .col-0 { background: #ffff66 }
552    .col-1 { background: #a0ffff }
553    .col-2 { background: #99ff99 }
554    .col-3 { background: #ff9999 }
555    .col-4 { background: #ff66ff }
556    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
557    a:hover.tag { border: 1px solid #eee }
558    _END_OF_STYLE_
559    
560    my $max_color = 4;
561    
562    my %nick_enumerator;
563    
564    sub root_handler {
565            my ($request, $response) = @_;
566            $response->code(RC_OK);
567            $response->content_type("text/html; charset=$ENCODING");
568    
569            my $q;
570    
571            if ( $request->method eq 'POST' ) {
572                    $q = new CGI::Simple( $request->content );
573            } elsif ( $request->uri =~ /\?(.+)$/ ) {
574                    $q = new CGI::Simple( $1 );
575            } else {
576                    $q = new CGI::Simple;
577            }
578    
579            my $search = $q->param('search') || $q->param('grep') || '';
580    
581            $response->content(
582                    qq{<html><head><title>$NICK</title><style type="text/css">$style} .
583                    $cloud->css .
584                    qq{</style></head><body>} .
585                    qq{
586                    <form method="post" class="search">
587                    <input type="text" name="search" value="$search" size="10">
588                    <input type="submit" value="search">
589                    </form>
590                    } .
591                    $cloud->html(500) .
592                    qq{<p>} .
593                    join("</p><p>",
594                            get_from_log(
595                                    limit => $q->param('last') || 100,
596                                    search => $search || undef,
597                                    tag => $q->param('tag') || undef,
598                                    fmt => {
599                                            date => '<hr size="1" style="clear: both;"/><div class="date">%s</div> ',
600                                            time => '<span class="time">%s</span> ',
601                                            time_channel => '<span class="channel">%s %s</span> ',
602                                            nick => '%s:&nbsp;',
603                                            me_nick => '***%s&nbsp;',
604                                            message => '<span class="message">%s</span>',
605                                    },
606                                    filter => {
607                                            message => sub {
608                                                    my $m = shift || return;
609                                                    $m =~ s/($escape_re)/$escape{$1}/gs;
610                                                    $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;
611                                                    $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;
612                                                    return $m;
613                                            },
614                                            nick => sub {
615                                                    my $n = shift || return;
616                                                    if (! $nick_enumerator{$n})  {
617                                                            my $max = scalar keys %nick_enumerator;
618                                                            $nick_enumerator{$n} = $max + 1;
619                                                    }
620                                                    return '<span class="nick col-' .
621                                                            ( $nick_enumerator{$n} % $max_color ) .
622                                                            '">' . $n . '</span>';
623                                            },
624                                    },
625                            )
626                    ) .
627                    qq{</p></body></html>}
628            );
629            return RC_OK;
630    }
631    
632  POE::Kernel->run;  POE::Kernel->run;
Legend:
Removed from v.5  
changed lines
  Added in v.31
  ViewVC Help
Powered by ViewVC 1.1.26