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

Legend:
Removed from v.6  
changed lines
  Added in v.29

  ViewVC Help
Powered by ViewVC 1.1.26