/[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 11 by dpavlin, Thu Mar 2 00:52:22 2006 UTC revision 32 by dpavlin, Mon Jun 19 11:32:16 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  =head2 get_from_log
89    
90   my @messages = get_from_log(   my @messages = get_from_log(
91          limit => 42,          limit => 42,
92          search => '%what to stuff in ilike%',          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  =cut
115    
116  sub get_from_log {  sub get_from_log {
# Line 86  sub get_from_log { Line 118  sub get_from_log {
118    
119          $args->{limit} ||= 10;          $args->{limit} ||= 10;
120    
121          my $sql = qq{          $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                  select
132                          time::date as date,                          time::date as date,
133                          time::time as time,                          time::time as time,
134                          channel,                          channel,
135                            me,
136                          nick,                          nick,
137                          message                          message
138                  from log                  from log
139          };          };
140          $sql .= " where message ilike ? " if ($args->{search});  
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";          $sql .= " order by log.time desc";
154          $sql .= " limit " . $args->{limit};          $sql .= " limit " . $args->{limit};
155    
156          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
157          if ($args->{search}) {          if (my $search = $args->{search}) {
158                  $sth->execute( $args->{search} );                  $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 {          } else {
166                  $sth->execute();                  $sth->execute();
167          }          }
# Line 118  sub get_from_log { Line 178  sub get_from_log {
178                  unshift @rows, $row;                  unshift @rows, $row;
179          }          }
180    
181          my @msgs;          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) {          foreach my $row (@rows) {
210    
211                  $row->{time} =~ s#\.\d+##;                  $row->{time} =~ s#\.\d+##;
212    
                 my $t;  
                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                 $t .= $row->{time};  
   
213                  my $msg = '';                  my $msg = '';
214    
215                  $msg .= "($t";                  $msg = sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
216                  $msg .= ' ' . $row->{channel} if ($last_row->{channel} ne $row->{channel});                  my $t = $row->{time};
                 $msg .= ") ";  
217    
218                  $msg .= $row->{nick} . ': '  if ($last_row->{nick} ne $row->{nick});                  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                  $msg .= $row->{message};                          $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
237    
238                  push @msgs, $msg;                          $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;                  $last_row = $row;
260          }          }
# Line 171  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;                  my @out;
# Line 215  POE::Session->create Line 346  POE::Session->create
346    
347                          foreach my $res (get_from_log( limit => $1 )) {                          foreach my $res (get_from_log( limit => $1 )) {
348                                  print "last: $res\n";                                  print "last: $res\n";
349                                  from_to($res, 'ISO-8859-2', 'UTF-8');                                  from_to($res, $ENCODING, 'UTF-8');
350                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
351                          }                          }
352    
353                          $res = '';                          $res = '';
354    
355                  } elsif ($msg =~ m/^(search|grep)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
356    
357                          my $what = $2;                          my $what = $2;
358    
359                          foreach my $res (get_from_log( limit => 20, search => "%${what}%" )) {                          foreach my $res (get_from_log(
360                                            limit => 20,
361                                            search => $what,
362                                    )) {
363                                  print "search [$what]: $res\n";                                  print "search [$what]: $res\n";
364                                  from_to($res, 'ISO-8859-2', 'UTF-8');                                  from_to($res, $ENCODING, 'UTF-8');
365                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
366                          }                          }
367    
# Line 237  POE::Session->create Line 371  POE::Session->create
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 350  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                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
511            }
512    }
513    
514    =head2 seed_tags
515    
516    Read all tags from database and create in-memory cache for tags
517    
518    =cut
519    
520    sub seed_tags {
521            my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });
522            $sth->execute;
523            while (my $row = $sth->fetchrow_hashref) {
524                    add_tag( %$row );
525            }
526    
527            foreach my $tag (keys %$tags) {
528                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
529            }
530    }
531    
532    seed_tags;
533    
534    # http server
535    
536    my $httpd = POE::Component::Server::HTTP->new(
537            Port => $NICK =~ m/-dev/ ? 8001 : 8000,
538            ContentHandler => { '/' => \&root_handler },
539            Headers        => { Server => 'irc-logger' },
540    );
541    
542    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
543    my $escape_re  = join '|' => keys %escape;
544    
545    my $style = <<'_END_OF_STYLE_';
546    p { margin: 0; padding: 0.1em; }
547    .time, .channel { color: #808080; font-size: 60%; }
548    .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
549    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
550    .message { color: #000000; font-size: 100%; }
551    .search { float: right; }
552    .col-0 { background: #ffff66 }
553    .col-1 { background: #a0ffff }
554    .col-2 { background: #99ff99 }
555    .col-3 { background: #ff9999 }
556    .col-4 { background: #ff66ff }
557    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
558    a:hover.tag { border: 1px solid #eee }
559    _END_OF_STYLE_
560    
561    my $max_color = 4;
562    
563    my %nick_enumerator;
564    
565    sub root_handler {
566            my ($request, $response) = @_;
567            $response->code(RC_OK);
568            $response->content_type("text/html; charset=$ENCODING");
569    
570            my $q;
571    
572            if ( $request->method eq 'POST' ) {
573                    $q = new CGI::Simple( $request->content );
574            } elsif ( $request->uri =~ /\?(.+)$/ ) {
575                    $q = new CGI::Simple( $1 );
576            } else {
577                    $q = new CGI::Simple;
578            }
579    
580            my $search = $q->param('search') || $q->param('grep') || '';
581    
582            $response->content(
583                    qq{<html><head><title>$NICK</title><style type="text/css">$style} .
584                    $cloud->css .
585                    qq{</style></head><body>} .
586                    qq{
587                    <form method="post" class="search" action="/">
588                    <input type="text" name="search" value="$search" size="10">
589                    <input type="submit" value="search">
590                    </form>
591                    } .
592                    $cloud->html(500) .
593                    qq{<p>} .
594                    join("</p><p>",
595                            get_from_log(
596                                    limit => $q->param('last') || 100,
597                                    search => $search || undef,
598                                    tag => $q->param('tag') || undef,
599                                    fmt => {
600                                            date => '<hr size="1" style="clear: both;"/><div class="date">%s</div> ',
601                                            time => '<span class="time">%s</span> ',
602                                            time_channel => '<span class="channel">%s %s</span> ',
603                                            nick => '%s:&nbsp;',
604                                            me_nick => '***%s&nbsp;',
605                                            message => '<span class="message">%s</span>',
606                                    },
607                                    filter => {
608                                            message => sub {
609                                                    my $m = shift || return;
610                                                    $m =~ s/($escape_re)/$escape{$1}/gs;
611                                                    $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;
612                                                    $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;
613                                                    return $m;
614                                            },
615                                            nick => sub {
616                                                    my $n = shift || return;
617                                                    if (! $nick_enumerator{$n})  {
618                                                            my $max = scalar keys %nick_enumerator;
619                                                            $nick_enumerator{$n} = $max + 1;
620                                                    }
621                                                    return '<span class="nick col-' .
622                                                            ( $nick_enumerator{$n} % $max_color ) .
623                                                            '">' . $n . '</span>';
624                                            },
625                                    },
626                            )
627                    ) .
628                    qq{</p></body></html>}
629            );
630            return RC_OK;
631    }
632    
633  POE::Kernel->run;  POE::Kernel->run;

Legend:
Removed from v.11  
changed lines
  Added in v.32

  ViewVC Help
Powered by ViewVC 1.1.26