/[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 18 by dpavlin, Mon Mar 13 17:07:40 2006 UTC revision 31 by dpavlin, Sat Jun 17 17:23:26 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-dev';  my $NICK = 'irc-logger';
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 44  my $ENCODING = 'ISO-8859-2'; Line 44  my $ENCODING = 'ISO-8859-2';
44  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
45  use HTTP::Status;  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/;  use Regexp::Common qw /URI/;
49  use CGI::Simple;  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 67  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(
# Line 86  values (?,?,?) Line 94  values (?,?,?)
94                  time => '{%s} ',                  time => '{%s} ',
95                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
96                  nick => '%s: ',                  nick => '%s: ',
97                    me_nick => '***%s ',
98                  message => '%s',                  message => '%s',
99          },          },
100          message_filter => sub {          filter => {
101                  # modify message content                  message => sub {
102                  return shift;                          # 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 102  sub get_from_log { Line 119  sub get_from_log {
119          $args->{limit} ||= 10;          $args->{limit} ||= 10;
120    
121          $args->{fmt} ||= {          $args->{fmt} ||= {
122                    date => '[%s] ',
123                  time => '{%s} ',                  time => '{%s} ',
124                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
125                  nick => '%s: ',                  nick => '%s: ',
126                    me_nick => '***%s ',
127                  message => '%s',                  message => '%s',
128          };          };
129    
130          my $sql = qq{          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                  warn "search for '$args->{search}' returned ", $sth->rows, " results\n";                  $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 145  sub get_from_log { Line 182  sub get_from_log {
182                  "Showing " . ($#rows + 1) . " messages..."                  "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 = 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}) {                  if ($last_row->{channel} ne $row->{channel}) {
219                          $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});                          $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
220                  } else {                  } else {
# Line 163  sub get_from_log { Line 223  sub get_from_log {
223    
224                  my $append = 1;                  my $append = 1;
225    
226                  if ($last_row->{nick} ne $row->{nick}) {                  my $nick = $row->{nick};
227                          $msg .= sprintf($args->{fmt}->{nick}, $row->{nick});                  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;                          $append = 0;
240                  }                  }
241    
242                  if (ref($args->{message_filter}) eq 'CODE') {                  $args->{fmt}->{message} ||= '%s';
243                    if (ref($args->{filter}->{message}) eq 'CODE') {
244                          $msg .= sprintf($args->{fmt}->{message},                          $msg .= sprintf($args->{fmt}->{message},
245                                  $args->{message_filter}->(                                  $args->{filter}->{message}->(
246                                          $row->{message}                                          $row->{message}
247                                  )                                  )
248                          );                          );
# Line 218  POE::Session->create Line 290  POE::Session->create
290                  from_to($msg, 'UTF-8', $ENCODING);                  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];
# Line 265  POE::Session->create Line 352  POE::Session->create
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, $ENCODING, 'UTF-8');                                  from_to($res, $ENCODING, 'UTF-8');
365                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
# Line 394  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  # http server
534    
535  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
# Line 408  my $escape_re  = join '|' => keys %escap Line 544  my $escape_re  = join '|' => keys %escap
544  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
545  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
546  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
547  .nick { color: #0000ff; font-size: 80%; }  .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%; }  .message { color: #000000; font-size: 100%; }
550  .search { float: right; }  .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_  _END_OF_STYLE_
559    
560    my $max_color = 4;
561    
562    my %nick_enumerator;
563    
564  sub root_handler {  sub root_handler {
565          my ($request, $response) = @_;          my ($request, $response) = @_;
566          $response->code(RC_OK);          $response->code(RC_OK);
# Line 431  sub root_handler { Line 579  sub root_handler {
579          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
580    
581          $response->content(          $response->content(
582                  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} .
583                    $cloud->css .
584                    qq{</style></head><body>} .
585                    qq{
586                  <form method="post" class="search">                  <form method="post" class="search">
587                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
588                  <input type="submit" value="search">                  <input type="submit" value="search">
589                  </form>                  </form>
                 <p>  
590                  } .                  } .
591                    $cloud->html(500) .
592                    qq{<p>} .
593                  join("</p><p>",                  join("</p><p>",
594                          get_from_log(                          get_from_log(
595                                  limit => $q->param('limit') || 100,                                  limit => $q->param('last') || 100,
596                                  search => $q->param('search') || $q->param('grep') || undef,                                  search => $search || undef,
597                                    tag => $q->param('tag') || undef,
598                                  fmt => {                                  fmt => {
599                                            date => '<hr size="1" style="clear: both;"/><div class="date">%s</div> ',
600                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
601                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
602                                          nick => '<span class="nick">%s:</span> ',                                          nick => '%s:&nbsp;',
603                                            me_nick => '***%s&nbsp;',
604                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
605                                  },                                  },
606                                  message_filter => sub {                                  filter => {
607                                          my $m = shift || return;                                          message => sub {
608                                          $m =~ s/($escape_re)/$escape{$1}/gs;                                                  my $m = shift || return;
609                                          $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;                                                  $m =~ s/($escape_re)/$escape{$1}/gs;
610                                          return $m;                                                  $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                  ) .                  ) .

Legend:
Removed from v.18  
changed lines
  Added in v.31

  ViewVC Help
Powered by ViewVC 1.1.26