/[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 10 by dpavlin, Thu Mar 2 00:19:12 2006 UTC revision 31 by dpavlin, Sat Jun 17 17:23:26 2006 UTC
# 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 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 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    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 89  POE::Session->create Line 279  POE::Session->create
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];
# Line 96  POE::Session->create Line 287  POE::Session->create
287                  my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
288                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
289    
290                  from_to($msg, 'UTF-8', 'ISO-8859-2');                  from_to($msg, 'UTF-8', $ENCODING);
291    
292                  print "$channel: <$nick> $msg\n";                  print "$channel: <$nick> $msg\n";
293                  $sth->execute($channel, $nick, $msg);                  $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 {          irc_msg => sub {
311                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
312                  my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
313                  my $msg = $_[ARG2];                  my $msg = $_[ARG2];
314                  from_to($msg, 'UTF-8', 'ISO-8859-2');                  from_to($msg, 'UTF-8', $ENCODING);
315    
316                  my $res = "unknown command '$msg', try /msg $NICK help!";                  my $res = "unknown command '$msg', try /msg $NICK help!";
317                    my @out;
318    
319                  print "<< $msg\n";                  print "<< $msg\n";
320    
321                  if ($msg =~ m/^help/i) {                  if ($msg =~ m/^help/i) {
322    
323                          $res = "usage: /msg $NICK stat - shows user statistics | /msg $NICK last - show backtrace of conversations";                          $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
324    
325                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {                  } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
326    
# Line 137  POE::Session->create Line 344  POE::Session->create
344                          $res .= join(" | ", @users);                          $res .= join(" | ", @users);
345                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {                  } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
346    
347                          my $nr = $1 || 10;                          foreach my $res (get_from_log( limit => $1 )) {
348                                    print "last: $res\n";
349                          my $sth = $dbh->prepare(qq{                                  from_to($res, $ENCODING, 'UTF-8');
350                                  select                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
                                         time::date as date,  
                                         time::time as time,  
                                         channel,  
                                         nick,  
                                         message  
                                 from log order by log.time desc limit $nr  
                         });  
                         $sth->execute();  
                         $res = "Last $nr messages: ";  
                         my $last_row = {  
                                 date => '',  
                                 time => '',  
                                 channel => '',  
                                 nick => '',  
                         };  
   
                         my @rows;  
   
                         while (my $row = $sth->fetchrow_hashref) {  
                                 unshift @rows, $row;  
351                          }                          }
352    
353                          my @msgs;                          $res = '';
   
                         foreach my $row (@rows) {  
   
                                 $row->{time} =~ s#\.\d+##;  
   
                                 my $t;  
                                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                                 $t .= $row->{time};  
   
                                 my $msg = '';  
   
                                 $msg .= "($t";  
                                 $msg .= ' ' . $row->{channel} if ($last_row->{channel} ne $row->{channel});  
                                 $msg .= ") ";  
   
                                 $msg .= $row->{nick} . ': '  if ($last_row->{nick} ne $row->{nick});  
   
                                 $msg .= $row->{message};  
354    
355                                  push @msgs, $msg;                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
356    
357                                  $last_row = $row;                          my $what = $2;
                         }  
358    
359                          foreach my $res (@msgs) {                          foreach my $res (get_from_log(
360                                  print "last: $res\n";                                          limit => 20,
361                                  from_to($res, 'ISO-8859-2', 'UTF-8');                                          search => $what,
362                                    )) {
363                                    print "search [$what]: $res\n";
364                                    from_to($res, $ENCODING, 'UTF-8');
365                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
366                          }                          }
367    
368                          $res = '';                          $res = '';
369    
370                  }                  }
371    
372                  if ($res) {                  if ($res) {
373                          print ">> [$nick] $res\n";                          print ">> [$nick] $res\n";
374                          from_to($res, 'ISO-8859-2', 'UTF-8');                          from_to($res, $ENCODING, 'UTF-8');
375                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                          $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
376                  }                  }
377    
# Line 218  POE::Session->create Line 390  POE::Session->create
390                  warn "## indetify $NICK\n";                  warn "## indetify $NICK\n";
391                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
392          },          },
393          irc_433 => sub {  #       irc_433 => sub {
394                  print "# irc_433: ",$_[ARG1], "\n";  #               print "# irc_433: ",$_[ARG1], "\n";
395                  warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
396                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
397          },  #       },
398          irc_372 => sub {          irc_372 => sub {
399                  print "MOTD: ", $_[ARG1], "\n";                  print "MOTD: ", $_[ARG1], "\n";
400          },          },
# Line 312  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.10  
changed lines
  Added in v.31
  ViewVC Help
Powered by ViewVC 1.1.26