/[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 17 by dpavlin, Mon Mar 13 16:50:07 2006 UTC revision 34 by dpavlin, Sat Jun 24 22:57: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 $HOSTNAME = `hostname`;
22    
23    my $NICK = 'irc-logger';
24    $NICK .= '-dev' if ($HOSTNAME =~ m/llin/);
25  my $CONNECT =  my $CONNECT =
26    {Server => 'irc.freenode.net',    {Server => 'irc.freenode.net',
27     Nick => $NICK,     Nick => $NICK,
28     Ircname => "try /msg $NICK help",     Ircname => "try /msg $NICK help",
29    };    };
30  my $CHANNEL = '#razmjenavjestina';  my $CHANNEL = '#razmjenavjestina';
31    $CHANNEL = '#irc-logger' if ($HOSTNAME =~ m/llin/);
32  my $IRC_ALIAS = "log";  my $IRC_ALIAS = "log";
33    
34  my %FOLLOWS =  my %FOLLOWS =
# Line 33  my %FOLLOWS = Line 37  my %FOLLOWS =
37     ERROR => "/var/log/apache/error.log",     ERROR => "/var/log/apache/error.log",
38    );    );
39    
40  my $DSN = 'DBI:Pg:dbname=irc-logger';  my $DSN = 'DBI:Pg:dbname=' . $NICK;
41    
42  my $ENCODING = 'ISO-8859-2';  my $ENCODING = 'ISO-8859-2';
43    my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
44    
45  ## END CONFIG  ## END CONFIG
46    
# Line 44  my $ENCODING = 'ISO-8859-2'; Line 49  my $ENCODING = 'ISO-8859-2';
49  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
50  use HTTP::Status;  use HTTP::Status;
51  use DBI;  use DBI;
52  use Encode qw/from_to/;  use Encode qw/from_to is_utf8/;
53  use Regexp::Common qw /URI/;  use Regexp::Common qw /URI/;
54  use CGI::Simple;  use CGI::Simple;
55    use HTML::TagCloud;
56    use POSIX qw/strftime/;
57    
58  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
59    
60  =for SQL schema  eval {
61            $dbh->do(qq{ select count(*) from log });
62    };
63    
64    if ($@) {
65            warn "creating database table in $DSN\n";
66            $dbh->do(<<'_SQL_SCHEMA_');
67    
 $dbh->do(qq{  
68  create table log (  create table log (
69          id serial,          id serial,
70          time timestamp default now(),          time timestamp default now(),
71          channel text not null,          channel text not null,
72            me boolean default false,
73          nick text not null,          nick text not null,
74          message text not null,          message text not null,
75          primary key(id)          primary key(id)
# Line 67  create index log_time on log(time); Line 79  create index log_time on log(time);
79  create index log_channel on log(channel);  create index log_channel on log(channel);
80  create index log_nick on log(nick);  create index log_nick on log(nick);
81    
82  });  _SQL_SCHEMA_
83    }
 =cut  
84    
85  my $sth = $dbh->prepare(qq{  my $sth = $dbh->prepare(qq{
86  insert into log  insert into log
87          (channel, nick, message)          (channel, me, nick, message)
88  values (?,?,?)  values (?,?,?,?)
89  });  });
90    
91    my $tags;
92    my $tag_regex = '\b([\w-_]+)//';
93    
94  =head2 get_from_log  =head2 get_from_log
95    
96   my @messages = get_from_log(   my @messages = get_from_log(
# Line 86  values (?,?,?) Line 100  values (?,?,?)
100                  time => '{%s} ',                  time => '{%s} ',
101                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
102                  nick => '%s: ',                  nick => '%s: ',
103                    me_nick => '***%s ',
104                  message => '%s',                  message => '%s',
105          },          },
106          message_filter => sub {          filter => {
107                  # modify message content                  message => sub {
108                  return shift;                          # modify message content
109          }                          return shift;
110                    }
111            },
112            context => 5,
113   );   );
114    
115    Order is important. Fields are first passed through C<filter> (if available) and
116    then throgh C<< sprintf($fmt->{message}, $message >> if available.
117    
118    C<context> defines number of messages around each search hit for display.
119    
120  =cut  =cut
121    
122  sub get_from_log {  sub get_from_log {
# Line 102  sub get_from_log { Line 125  sub get_from_log {
125          $args->{limit} ||= 10;          $args->{limit} ||= 10;
126    
127          $args->{fmt} ||= {          $args->{fmt} ||= {
128                    date => '[%s] ',
129                  time => '{%s} ',                  time => '{%s} ',
130                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
131                  nick => '%s: ',                  nick => '%s: ',
132                    me_nick => '***%s ',
133                  message => '%s',                  message => '%s',
134          };          };
135    
136          my $sql = qq{          my $sql_message = qq{
137                  select                  select
138                          time::date as date,                          time::date as date,
139                          time::time as time,                          time::time as time,
140                          channel,                          channel,
141                            me,
142                          nick,                          nick,
143                          message                          message
144                  from log                  from log
145          };          };
146          $sql .= " where message ilike ? " if ($args->{search});  
147            my $sql_context = qq{
148                    select
149                            id
150                    from log
151            };
152    
153            my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
154    
155            my $sql = $context ? $sql_context : $sql_message;
156    
157            $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});
158            $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });
159          $sql .= " order by log.time desc";          $sql .= " order by log.time desc";
160          $sql .= " limit " . $args->{limit};          $sql .= " limit " . $args->{limit};
161    
162          my $sth = $dbh->prepare( $sql );          my $sth = $dbh->prepare( $sql );
163          if ($args->{search}) {          if (my $search = $args->{search}) {
164                  $sth->execute( '%' . $args->{search} . '%' );                  $search =~ s/^\s+//;
165                  warn "search for '$args->{search}' returned ", $sth->rows, " results\n";                  $search =~ s/\s+$//;
166                    $sth->execute( ( '%' . $search . '%' ) x 2 );
167                    warn "search for '$search' returned ", $sth->rows, " results ", $context || '', "\n";
168            } elsif (my $tag = $args->{tag}) {
169                    $sth->execute();
170                    warn "tag '$tag' returned ", $sth->rows, " results ", $context || '', "\n";
171          } else {          } else {
172                  $sth->execute();                  $sth->execute();
173          }          }
# Line 145  sub get_from_log { Line 188  sub get_from_log {
188                  "Showing " . ($#rows + 1) . " messages..."                  "Showing " . ($#rows + 1) . " messages..."
189          );          );
190    
191            if ($context) {
192                    my @ids = @rows;
193                    @rows = ();
194    
195                    my $last_to = 0;
196    
197                    my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
198                    foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
199                            my $id = $row_id->{id} || die "can't find id in row";
200            
201                            my ($from, $to) = ($id - $context, $id + $context);
202                            $from = $last_to if ($from < $last_to);
203                            $last_to = $to;
204                            $sth->execute( $from, $to );
205    
206                            #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
207    
208                            while (my $row = $sth->fetchrow_hashref) {
209                                    push @rows, $row;
210                            }
211    
212                    }
213            }
214    
215          foreach my $row (@rows) {          foreach my $row (@rows) {
216    
217                  $row->{time} =~ s#\.\d+##;                  $row->{time} =~ s#\.\d+##;
218    
                 my $t;  
                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                 $t .= $row->{time};  
   
219                  my $msg = '';                  my $msg = '';
220    
221                    $msg = sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
222                    my $t = $row->{time};
223    
224                  if ($last_row->{channel} ne $row->{channel}) {                  if ($last_row->{channel} ne $row->{channel}) {
225                          $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});                          $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
226                  } else {                  } else {
# Line 163  sub get_from_log { Line 229  sub get_from_log {
229    
230                  my $append = 1;                  my $append = 1;
231    
232                  if ($last_row->{nick} ne $row->{nick}) {                  my $nick = $row->{nick};
233                          $msg .= sprintf($args->{fmt}->{nick}, $row->{nick});                  if ($nick =~ s/^_*(.*?)_*$/$1/) {
234                            $row->{nick} = $nick;
235                    }
236    
237                    if ($last_row->{nick} ne $nick) {
238                            # obfu way to find format for me_nick if needed or fallback to default
239                            my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
240                            $fmt ||= '%s';
241    
242                            $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
243    
244                            $msg .= sprintf( $fmt, $nick );
245                          $append = 0;                          $append = 0;
246                  }                  }
247    
248                  if (ref($args->{message_filter}) eq 'CODE') {                  $args->{fmt}->{message} ||= '%s';
249                    if (ref($args->{filter}->{message}) eq 'CODE') {
250                          $msg .= sprintf($args->{fmt}->{message},                          $msg .= sprintf($args->{fmt}->{message},
251                                  $args->{message_filter}->(                                  $args->{filter}->{message}->(
252                                          $row->{message}                                          $row->{message}
253                                  )                                  )
254                          );                          );
# Line 196  my $SEND_QUEUE;                 # cache Line 274  my $SEND_QUEUE;                 # cache
274    
275  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
276    
277  POE::Session->create  POE::Session->create( inline_states =>
   (inline_states =>  
278     {_start => sub {           {_start => sub {      
279                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
280                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
# Line 218  POE::Session->create Line 295  POE::Session->create
295                  from_to($msg, 'UTF-8', $ENCODING);                  from_to($msg, 'UTF-8', $ENCODING);
296    
297                  print "$channel: <$nick> $msg\n";                  print "$channel: <$nick> $msg\n";
298                  $sth->execute($channel, $nick, $msg);                  $sth->execute($channel, 0, $nick, $msg);
299                    add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),
300                            message => $msg);
301        },
302        irc_ctcp_action => sub {
303                    my $kernel = $_[KERNEL];
304                    my $nick = (split /!/, $_[ARG0])[0];
305                    my $channel = $_[ARG1]->[0];
306                    my $msg = $_[ARG2];
307    
308                    from_to($msg, 'UTF-8', $ENCODING);
309    
310                    print "$channel ***$nick $msg\n";
311                    $sth->execute($channel, 1, $nick, $msg);
312                    add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),
313                            message => $msg);
314      },      },
315          irc_msg => sub {          irc_msg => sub {
316                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 265  POE::Session->create Line 357  POE::Session->create
357    
358                          $res = '';                          $res = '';
359    
360                  } elsif ($msg =~ m/^(search|grep)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
361    
362                          my $what = $2;                          my $what = $2;
363    
364                          foreach my $res (get_from_log( limit => 20, search => $what )) {                          foreach my $res (get_from_log(
365                                            limit => 20,
366                                            search => $what,
367                                    )) {
368                                  print "search [$what]: $res\n";                                  print "search [$what]: $res\n";
369                                  from_to($res, $ENCODING, 'UTF-8');                                  from_to($res, $ENCODING, 'UTF-8');
370                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
# Line 305  POE::Session->create Line 400  POE::Session->create
400  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
401  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
402  #       },  #       },
         irc_372 => sub {  
                 print "MOTD: ", $_[ARG1], "\n";  
         },  
         irc_snotice => sub {  
                 print "(server notice): ", $_[ARG0], "\n";  
         },  
     (map  
      {  
        ;"irc_$_" => sub { }}  
      qw(  
                 )),  
 #       join  
 #       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      _child => sub {},      _child => sub {},
404      _default => sub {      _default => sub {
405        printf "%s: session %s caught an unhandled %s event.\n",                  printf "%s #%s %s %s\n",
406          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          strftime($TIMESTAMP,localtime()), $_[SESSION]->ID, $_[ARG0],
407        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
408          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
409                            "";
410        0;                        # false for signals        0;                        # false for signals
411      },      },
412      my_add => sub {      my_add => sub {
# Line 394  POE::Session->create Line 472  POE::Session->create
472     },     },
473    );    );
474    
475    # tags support
476    
477    my $cloud = HTML::TagCloud->new;
478    
479    =head2 add_tag
480    
481     add_tag( id => 42, message => 'irc message' );
482    
483    =cut
484    
485    sub add_tag {
486            my $arg = {@_};
487    
488            return unless ($arg->{id} && $arg->{message});
489    
490            my $m = $arg->{message};
491            from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
492    
493            while ($m =~ s#$tag_regex##s) {
494                    my $tag = $1;
495                    next if (! $tag || $tag =~ m/https?:/i);
496                    push @{ $tags->{$tag} }, $arg->{id};
497                    #warn "+tag $tag: $arg->{id}\n";
498                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
499            }
500    }
501    
502    =head2 seed_tags
503    
504    Read all tags from database and create in-memory cache for tags
505    
506    =cut
507    
508    sub seed_tags {
509            my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });
510            $sth->execute;
511            while (my $row = $sth->fetchrow_hashref) {
512                    add_tag( %$row );
513            }
514    
515            foreach my $tag (keys %$tags) {
516                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
517            }
518    }
519    
520    seed_tags;
521    
522  # http server  # http server
523    
524  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
# Line 402  my $httpd = POE::Component::Server::HTTP Line 527  my $httpd = POE::Component::Server::HTTP
527          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
528  );  );
529    
530    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
531    my $escape_re  = join '|' => keys %escape;
532    
533  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
534  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
535  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
536  .nick { color: #0000ff; font-size: 80%; }  .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
537    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
538  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
539  .search { float: right; }  .search { float: right; }
540    .col-0 { background: #ffff66 }
541    .col-1 { background: #a0ffff }
542    .col-2 { background: #99ff99 }
543    .col-3 { background: #ff9999 }
544    .col-4 { background: #ff66ff }
545    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
546    a:hover.tag { border: 1px solid #eee }
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);
# Line 428  sub root_handler { Line 568  sub root_handler {
568          my $search = $q->param('search') || $q->param('grep') || '';          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                  <form method="post" class="search">                  $cloud->css .
573                    qq{</style></head><body>} .
574                    qq{
575                    <form method="post" class="search" action="/">
576                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
577                  <input type="submit" value="search">                  <input type="submit" value="search">
578                  </form>                  </form>
                 <p>  
579                  } .                  } .
580                    $cloud->html(500) .
581                    qq{<p>} .
582                  join("</p><p>",                  join("</p><p>",
583                          get_from_log(                          get_from_log(
584                                  limit => $q->param('limit') || 100,                                  limit => $q->param('last') || 100,
585                                  search => $q->param('search') || $q->param('grep') || undef,                                  search => $search || undef,
586                                    tag => $q->param('tag') || undef,
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                                                    $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;
601                                                    return $m;
602                                            },
603                                            nick => sub {
604                                                    my $n = shift || return;
605                                                    if (! $nick_enumerator{$n})  {
606                                                            my $max = scalar keys %nick_enumerator;
607                                                            $nick_enumerator{$n} = $max + 1;
608                                                    }
609                                                    return '<span class="nick col-' .
610                                                            ( $nick_enumerator{$n} % $max_color ) .
611                                                            '">' . $n . '</span>';
612                                            },
613                                  },                                  },
614                          )                          )
615                  ) .                  ) .

Legend:
Removed from v.17  
changed lines
  Added in v.34

  ViewVC Help
Powered by ViewVC 1.1.26