/[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 15 by dpavlin, Mon Mar 13 12:56:26 2006 UTC revision 28 by dpavlin, Fri Jun 16 20:51:32 2006 UTC
# Line 18  log all conversation on irc channel Line 18  log all conversation on irc channel
18    
19  ## CONFIG  ## CONFIG
20    
21  my $NICK = 'irc-logger';  my $NICK = 'irc-logger-dev';
22  my $CONNECT =  my $CONNECT =
23    {Server => 'irc.freenode.net',    {Server => 'irc.freenode.net',
24     Nick => $NICK,     Nick => $NICK,
# 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';  my $ENCODING = 'ISO-8859-2';
39    
# Line 46  use HTTP::Status; Line 46  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/;  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 66  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  =head2 get_from_log
88    
89   my @messages = get_from_log(   my @messages = get_from_log(
# Line 85  values (?,?,?) Line 93  values (?,?,?)
93                  time => '{%s} ',                  time => '{%s} ',
94                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
95                  nick => '%s: ',                  nick => '%s: ',
96                    me_nick => '***%s ',
97                  message => '%s',                  message => '%s',
98          },          },
99          message_filter => sub {          filter => {
100                  # modify message content                  message => sub {
101                  return shift;                          # 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  =cut
114    
115  sub get_from_log {  sub get_from_log {
# Line 101  sub get_from_log { Line 118  sub get_from_log {
118          $args->{limit} ||= 10;          $args->{limit} ||= 10;
119    
120          $args->{fmt} ||= {          $args->{fmt} ||= {
121                    date => '[%s] ',
122                  time => '{%s} ',                  time => '{%s} ',
123                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
124                  nick => '%s: ',                  nick => '%s: ',
125                    me_nick => '***%s ',
126                  message => '%s',                  message => '%s',
127          };          };
128    
129          my $sql = qq{          my $sql_message = qq{
130                  select                  select
131                          time::date as date,                          time::date as date,
132                          time::time as time,                          time::time as time,
133                          channel,                          channel,
134                            me,
135                          nick,                          nick,
136                          message                          message
137                  from log                  from log
138          };          };
139          $sql .= " where message ilike ? " if ($args->{search});  
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";          $sql .= " order by log.time desc";
153          $sql .= " limit " . $args->{limit};          $sql .= " limit " . $args->{limit};
154    
155          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
156          if ($args->{search}) {          if (my $search = $args->{search}) {
157                  $sth->execute( $args->{search} );                  $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 {          } else {
165                  $sth->execute();                  $sth->execute();
166          }          }
# Line 139  sub get_from_log { Line 177  sub get_from_log {
177                  unshift @rows, $row;                  unshift @rows, $row;
178          }          }
179    
180          my @msgs;          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) {          foreach my $row (@rows) {
209    
210                  $row->{time} =~ s#\.\d+##;                  $row->{time} =~ s#\.\d+##;
211    
                 my $t;  
                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                 $t .= $row->{time};  
   
212                  my $msg = '';                  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}) {                  if ($last_row->{channel} ne $row->{channel}) {
218                          $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});                          $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
219                  } else {                  } else {
# Line 159  sub get_from_log { Line 222  sub get_from_log {
222    
223                  my $append = 1;                  my $append = 1;
224    
225                  if ($last_row->{nick} ne $row->{nick}) {                  my $nick = $row->{nick};
226                          $msg .= sprintf($args->{fmt}->{nick}, $row->{nick});                  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;                          $append = 0;
239                  }                  }
240    
241                  if (ref($args->{message_filter}) eq 'CODE') {                  $args->{fmt}->{message} ||= '%s';
242                    if (ref($args->{filter}->{message}) eq 'CODE') {
243                          $msg .= sprintf($args->{fmt}->{message},                          $msg .= sprintf($args->{fmt}->{message},
244                                  $args->{message_filter}->(                                  $args->{filter}->{message}->(
245                                          $row->{message}                                          $row->{message}
246                                  )                                  )
247                          );                          );
# Line 214  POE::Session->create Line 289  POE::Session->create
289                  from_to($msg, 'UTF-8', $ENCODING);                  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 {          irc_msg => sub {
306                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 261  POE::Session->create Line 347  POE::Session->create
347    
348                          $res = '';                          $res = '';
349    
350                  } elsif ($msg =~ m/^(search|grep)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
351    
352                          my $what = $2;                          my $what = $2;
353    
354                          foreach my $res (get_from_log( limit => 20, search => "%${what}%" )) {                          foreach my $res (get_from_log(
355                                            limit => 20,
356                                            search => $what,
357                                    )) {
358                                  print "search [$what]: $res\n";                                  print "search [$what]: $res\n";
359                                  from_to($res, $ENCODING, 'UTF-8');                                  from_to($res, $ENCODING, 'UTF-8');
360                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
# Line 390  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  # http server
525    
526  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
# Line 398  my $httpd = POE::Component::Server::HTTP Line 529  my $httpd = POE::Component::Server::HTTP
529          Headers        => { Server => 'irc-logger' },          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_';  my $style = <<'_END_OF_STYLE_';
536    p { margin: 0; padding: 0.1em; }
537  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
538  .nick { color: #0000ff; font-size: 80%; }  .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%; }  .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_  _END_OF_STYLE_
548    
549    my $max_color = 4;
550    
551    my %nick_enumerator;
552    
553  sub root_handler {  sub root_handler {
554          my ($request, $response) = @_;          my ($request, $response) = @_;
555          $response->code(RC_OK);          $response->code(RC_OK);
556          $response->content_type("text/html; charset=$ENCODING");          $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(          $response->content(
571                  qq{<html><head><title>$NICK</title><style type="text/css">$style</style></head><body>} .                  qq{<html><head><title>$NICK</title><style type="text/css">$style} .
572                  "irc-logger url: " . $request->uri . '<br/>' .                  $cloud->css .
573                  join("<br/>",                  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(                          get_from_log(
584                                  limit => 100,                                  limit => $q->param('last') || 100,
585                                    search => $search || undef,
586                                    tag => $q->param('tag'),
587                                  fmt => {                                  fmt => {
588                                            date => '<hr size="1" style="clear: both;"/><div class="date">%s</div> ',
589                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
590                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
591                                          nick => '<span class="nick">%s:</span> ',                                          nick => '%s:&nbsp;',
592                                            me_nick => '***%s&nbsp;',
593                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
594                                  },                                  },
595                                  message_filter => sub {                                  filter => {
596                                          my $m = shift || return;                                          message => sub {
597                                          $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;                                                  my $m = shift || return;
598                                          return $m;                                                  $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{</body></html>}                  qq{</p></body></html>}
616          );          );
617          return RC_OK;          return RC_OK;
618  }  }

Legend:
Removed from v.15  
changed lines
  Added in v.28

  ViewVC Help
Powered by ViewVC 1.1.26