/[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 35 by dpavlin, Sun Jun 25 00:10:13 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    use HTML::CalendarMonthSimple;
58    
59  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;  my $dbh = DBI->connect($DSN,"","", { RaiseError => 1, AutoCommit => 1 }) || die $DBI::errstr;
60    
61  =for SQL schema  eval {
62            $dbh->do(qq{ select count(*) from log });
63    };
64    
65    if ($@) {
66            warn "creating database table in $DSN\n";
67            $dbh->do(<<'_SQL_SCHEMA_');
68    
 $dbh->do(qq{  
69  create table log (  create table log (
70          id serial,          id serial,
71          time timestamp default now(),          time timestamp default now(),
72          channel text not null,          channel text not null,
73            me boolean default false,
74          nick text not null,          nick text not null,
75          message text not null,          message text not null,
76          primary key(id)          primary key(id)
# Line 67  create index log_time on log(time); Line 80  create index log_time on log(time);
80  create index log_channel on log(channel);  create index log_channel on log(channel);
81  create index log_nick on log(nick);  create index log_nick on log(nick);
82    
83  });  _SQL_SCHEMA_
84    }
 =cut  
85    
86  my $sth = $dbh->prepare(qq{  my $sth = $dbh->prepare(qq{
87  insert into log  insert into log
88          (channel, nick, message)          (channel, me, nick, message)
89  values (?,?,?)  values (?,?,?,?)
90  });  });
91    
92    my $tags;
93    my $tag_regex = '\b([\w-_]+)//';
94    
95  =head2 get_from_log  =head2 get_from_log
96    
97   my @messages = get_from_log(   my @messages = get_from_log(
# Line 86  values (?,?,?) Line 101  values (?,?,?)
101                  time => '{%s} ',                  time => '{%s} ',
102                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
103                  nick => '%s: ',                  nick => '%s: ',
104                    me_nick => '***%s ',
105                  message => '%s',                  message => '%s',
106          },          },
107          message_filter => sub {          filter => {
108                  # modify message content                  message => sub {
109                  return shift;                          # modify message content
110          }                          return shift;
111                    }
112            },
113            context => 5,
114   );   );
115    
116    Order is important. Fields are first passed through C<filter> (if available) and
117    then throgh C<< sprintf($fmt->{message}, $message >> if available.
118    
119    C<context> defines number of messages around each search hit for display.
120    
121  =cut  =cut
122    
123  sub get_from_log {  sub get_from_log {
124          my $args = {@_};          my $args = {@_};
125    
         $args->{limit} ||= 10;  
   
126          $args->{fmt} ||= {          $args->{fmt} ||= {
127                    date => '[%s] ',
128                  time => '{%s} ',                  time => '{%s} ',
129                  time_channel => '{%s %s} ',                  time_channel => '{%s %s} ',
130                  nick => '%s: ',                  nick => '%s: ',
131                    me_nick => '***%s ',
132                  message => '%s',                  message => '%s',
133          };          };
134    
135          my $sql = qq{          my $sql_message = qq{
136                  select                  select
137                          time::date as date,                          time::date as date,
138                          time::time as time,                          time::time as time,
139                          channel,                          channel,
140                            me,
141                          nick,                          nick,
142                          message                          message
143                  from log                  from log
144          };          };
145          $sql .= " where message ilike ? " if ($args->{search});  
146            my $sql_context = qq{
147                    select
148                            id
149                    from log
150            };
151    
152            my $context = $1 if ($args->{search} && $args->{search} =~ s/\s*\+(\d+)\s*/ /);
153    
154            my $sql = $context ? $sql_context : $sql_message;
155    
156            $sql .= " where message ilike ? or nick ilike ? " if ($args->{search});
157            $sql .= " where id in (" . join(",", @{ $tags->{ $args->{tag} } }) . ") " if ($args->{tag} && $tags->{ $args->{tag} });
158            $sql .= " where date(time) = ? " if ($args->{date});
159          $sql .= " order by log.time desc";          $sql .= " order by log.time desc";
160          $sql .= " limit " . $args->{limit};          $sql .= " limit " . $args->{limit} if ($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            } elsif (my $date = $args->{date}) {
172                    $sth->execute($date);
173                    warn "found ", $sth->rows, " messages for date $date ", $context || '', "\n";
174          } else {          } else {
175                  $sth->execute();                  $sth->execute();
176          }          }
# Line 145  sub get_from_log { Line 191  sub get_from_log {
191                  "Showing " . ($#rows + 1) . " messages..."                  "Showing " . ($#rows + 1) . " messages..."
192          );          );
193    
194            if ($context) {
195                    my @ids = @rows;
196                    @rows = ();
197    
198                    my $last_to = 0;
199    
200                    my $sth = $dbh->prepare( $sql_message . qq{ where id >= ? and id < ? } );
201                    foreach my $row_id (sort { $a->{id} <=> $b->{id} } @ids) {
202                            my $id = $row_id->{id} || die "can't find id in row";
203            
204                            my ($from, $to) = ($id - $context, $id + $context);
205                            $from = $last_to if ($from < $last_to);
206                            $last_to = $to;
207                            $sth->execute( $from, $to );
208    
209                            #warn "## id: $id from: $from to: $to returned: ", $sth->rows, "\n";
210    
211                            while (my $row = $sth->fetchrow_hashref) {
212                                    push @rows, $row;
213                            }
214    
215                    }
216            }
217    
218            # sprintf which can take coderef as first parametar
219            sub cr_sprintf {
220                    my $fmt = shift || return;
221                    if (ref($fmt) eq 'CODE') {
222                            $fmt->(@_);
223                    } else {
224                            sprintf($fmt, @_);
225                    }
226            }
227    
228          foreach my $row (@rows) {          foreach my $row (@rows) {
229    
230                  $row->{time} =~ s#\.\d+##;                  $row->{time} =~ s#\.\d+##;
231    
                 my $t;  
                 $t = $row->{date} . ' ' if ($last_row->{date} ne $row->{date});  
                 $t .= $row->{time};  
   
232                  my $msg = '';                  my $msg = '';
233    
234                    $msg = cr_sprintf($args->{fmt}->{date}, $row->{date}) . ' ' if ($last_row->{date} ne $row->{date});
235                    my $t = $row->{time};
236    
237                  if ($last_row->{channel} ne $row->{channel}) {                  if ($last_row->{channel} ne $row->{channel}) {
238                          $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});                          $msg .= cr_sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
239                  } else {                  } else {
240                          $msg .= sprintf($args->{fmt}->{time}, $t);                          $msg .= cr_sprintf($args->{fmt}->{time}, $t);
241                  }                  }
242    
243                  my $append = 1;                  my $append = 1;
244    
245                  if ($last_row->{nick} ne $row->{nick}) {                  my $nick = $row->{nick};
246                          $msg .= sprintf($args->{fmt}->{nick}, $row->{nick});                  if ($nick =~ s/^_*(.*?)_*$/$1/) {
247                            $row->{nick} = $nick;
248                    }
249    
250                    if ($last_row->{nick} ne $nick) {
251                            # obfu way to find format for me_nick if needed or fallback to default
252                            my $fmt = $row->{me} ? ( $args->{fmt}->{me_nick} || $args->{fmt}->{nick} ) : $args->{fmt}->{nick};
253                            $fmt ||= '%s';
254    
255                            $nick = $args->{filter}->{nick}->($nick) if (ref($args->{filter}->{nick}) eq 'CODE');
256    
257                            $msg .= cr_sprintf( $fmt, $nick );
258                          $append = 0;                          $append = 0;
259                  }                  }
260    
261                  if (ref($args->{message_filter}) eq 'CODE') {                  $args->{fmt}->{message} ||= '%s';
262                          $msg .= sprintf($args->{fmt}->{message},                  if (ref($args->{filter}->{message}) eq 'CODE') {
263                                  $args->{message_filter}->(                          $msg .= cr_sprintf($args->{fmt}->{message},
264                                    $args->{filter}->{message}->(
265                                          $row->{message}                                          $row->{message}
266                                  )                                  )
267                          );                          );
268                  } else {                  } else {
269                          $msg .= sprintf($args->{fmt}->{message}, $row->{message});                          $msg .= cr_sprintf($args->{fmt}->{message}, $row->{message});
270                  }                  }
271    
272                  if ($append && @msgs) {                  if ($append && @msgs) {
# Line 196  my $SEND_QUEUE;                 # cache Line 287  my $SEND_QUEUE;                 # cache
287    
288  POE::Component::IRC->new($IRC_ALIAS);  POE::Component::IRC->new($IRC_ALIAS);
289    
290  POE::Session->create  POE::Session->create( inline_states =>
   (inline_states =>  
291     {_start => sub {           {_start => sub {      
292                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');                  $_[KERNEL]->post($IRC_ALIAS => register => 'all');
293                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);                  $_[KERNEL]->post($IRC_ALIAS => connect => $CONNECT);
# Line 218  POE::Session->create Line 308  POE::Session->create
308                  from_to($msg, 'UTF-8', $ENCODING);                  from_to($msg, 'UTF-8', $ENCODING);
309    
310                  print "$channel: <$nick> $msg\n";                  print "$channel: <$nick> $msg\n";
311                  $sth->execute($channel, $nick, $msg);                  $sth->execute($channel, 0, $nick, $msg);
312                    add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),
313                            message => $msg);
314        },
315        irc_ctcp_action => sub {
316                    my $kernel = $_[KERNEL];
317                    my $nick = (split /!/, $_[ARG0])[0];
318                    my $channel = $_[ARG1]->[0];
319                    my $msg = $_[ARG2];
320    
321                    from_to($msg, 'UTF-8', $ENCODING);
322    
323                    print "$channel ***$nick $msg\n";
324                    $sth->execute($channel, 1, $nick, $msg);
325                    add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),
326                            message => $msg);
327      },      },
328          irc_msg => sub {          irc_msg => sub {
329                  my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
# Line 265  POE::Session->create Line 370  POE::Session->create
370    
371                          $res = '';                          $res = '';
372    
373                  } elsif ($msg =~ m/^(search|grep)\s+(.*)$/i) {                  } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
374    
375                          my $what = $2;                          my $what = $2;
376    
377                          foreach my $res (get_from_log( limit => 20, search => $what )) {                          foreach my $res (get_from_log(
378                                            limit => 20,
379                                            search => $what,
380                                    )) {
381                                  print "search [$what]: $res\n";                                  print "search [$what]: $res\n";
382                                  from_to($res, $ENCODING, 'UTF-8');                                  from_to($res, $ENCODING, 'UTF-8');
383                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );                                  $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
# Line 305  POE::Session->create Line 413  POE::Session->create
413  #               warn "## indetify $NICK\n";  #               warn "## indetify $NICK\n";
414  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );  #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
415  #       },  #       },
         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  
416      _child => sub {},      _child => sub {},
417      _default => sub {      _default => sub {
418        printf "%s: session %s caught an unhandled %s event.\n",                  printf "%s #%s %s %s\n",
419          scalar localtime(), $_[SESSION]->ID, $_[ARG0];                          strftime($TIMESTAMP,localtime()), $_[SESSION]->ID, $_[ARG0],
420        print "The $_[ARG0] event was given these parameters: ",                          ref($_[ARG1]) eq "ARRAY"        ?       join(",", map { ref($_) eq "ARRAY" ? join(";", @{$_}) : $_ } @{ $_[ARG1] })     :
421          join(" ", map({"ARRAY" eq ref $_ ? "[@$_]" : "$_"} @{$_[ARG1]})), "\n";                          $_[ARG1]                                        ?       $_[ARG1]                                        :
422                            "";
423        0;                        # false for signals        0;                        # false for signals
424      },      },
425      my_add => sub {      my_add => sub {
# Line 394  POE::Session->create Line 485  POE::Session->create
485     },     },
486    );    );
487    
488    # tags support
489    
490    my $cloud = HTML::TagCloud->new;
491    
492    =head2 add_tag
493    
494     add_tag( id => 42, message => 'irc message' );
495    
496    =cut
497    
498    sub add_tag {
499            my $arg = {@_};
500    
501            return unless ($arg->{id} && $arg->{message});
502    
503            my $m = $arg->{message};
504            from_to('UTF-8', 'iso-8859-2', $m) if (is_utf8($m));
505    
506            while ($m =~ s#$tag_regex##s) {
507                    my $tag = $1;
508                    next if (! $tag || $tag =~ m/https?:/i);
509                    push @{ $tags->{$tag} }, $arg->{id};
510                    #warn "+tag $tag: $arg->{id}\n";
511                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
512            }
513    }
514    
515    =head2 seed_tags
516    
517    Read all tags from database and create in-memory cache for tags
518    
519    =cut
520    
521    sub seed_tags {
522            my $sth = $dbh->prepare(qq{ select id,message from log where message like '%//%' });
523            $sth->execute;
524            while (my $row = $sth->fetchrow_hashref) {
525                    add_tag( %$row );
526            }
527    
528            foreach my $tag (keys %$tags) {
529                    $cloud->add($tag, "?tag=$tag", scalar @{$tags->{$tag}} + 1);
530            }
531    }
532    
533    seed_tags;
534    
535  # http server  # http server
536    
537  my $httpd = POE::Component::Server::HTTP->new(  my $httpd = POE::Component::Server::HTTP->new(
# Line 402  my $httpd = POE::Component::Server::HTTP Line 540  my $httpd = POE::Component::Server::HTTP
540          Headers        => { Server => 'irc-logger' },          Headers        => { Server => 'irc-logger' },
541  );  );
542    
543    my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
544    my $escape_re  = join '|' => keys %escape;
545    
546  my $style = <<'_END_OF_STYLE_';  my $style = <<'_END_OF_STYLE_';
547  p { margin: 0; padding: 0.1em; }  p { margin: 0; padding: 0.1em; }
548  .time, .channel { color: #808080; font-size: 60%; }  .time, .channel { color: #808080; font-size: 60%; }
549  .nick { color: #0000ff; font-size: 80%; }  .date { float: right; background: #e0e0e0; color: #404040; font-size: 120%; padding: 0.25em; border: 1px dashed #808080; }
550    .nick { color: #000000; font-size: 80%; padding: 2px; font-family: courier, courier new, monospace ; }
551  .message { color: #000000; font-size: 100%; }  .message { color: #000000; font-size: 100%; }
552  .search { float: right; }  .search { float: right; }
553    .col-0 { background: #ffff66 }
554    .col-1 { background: #a0ffff }
555    .col-2 { background: #99ff99 }
556    .col-3 { background: #ff9999 }
557    .col-4 { background: #ff66ff }
558    a:link.tag, a:visited.tag { border: 1px dashed #ccc; backgound: #ccc; text-decoration: none }
559    a:hover.tag { border: 1px solid #eee }
560    hr { border: 1px dashed #ccc; height: 1px; clear: both; }
561  _END_OF_STYLE_  _END_OF_STYLE_
562    
563    my $max_color = 4;
564    
565    my %nick_enumerator;
566    
567  sub root_handler {  sub root_handler {
568          my ($request, $response) = @_;          my ($request, $response) = @_;
569          $response->code(RC_OK);          $response->code(RC_OK);
# Line 427  sub root_handler { Line 581  sub root_handler {
581    
582          my $search = $q->param('search') || $q->param('grep') || '';          my $search = $q->param('search') || $q->param('grep') || '';
583    
584          $response->content(          my $html =
585                  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} .
586                  <form method="post" class="search">                  $cloud->css .
587                    qq{</style></head><body>} .
588                    qq{
589                    <form method="post" class="search" action="/">
590                  <input type="text" name="search" value="$search" size="10">                  <input type="text" name="search" value="$search" size="10">
591                  <input type="submit" value="search">                  <input type="submit" value="search">
592                  </form>                  </form>
                 <p>  
593                  } .                  } .
594                  join("</p><p>",                  $cloud->html(500) .
595                    qq{<p>};
596            if ($request->url =~ m#/history#) {
597                    my $sth = $dbh->prepare(qq{
598                            select date(time) as date,count(*) as nr
599                                    from log
600                                    group by date(time)
601                                    order by date(time) desc
602                    });
603                    $sth->execute();
604                    my ($l_yyyy,$l_mm) = (0,0);
605                    my $cal;
606                    while (my $row = $sth->fetchrow_hashref) {
607                            # this is probably PostgreSQL specific, expects ISO date
608                            my ($yyyy,$mm,$dd) = split(/-/, $row->{date});
609                            if ($yyyy != $l_yyyy || $mm != $l_mm) {
610                                    $html .= $cal->as_HTML() if ($cal);
611                                    $cal = new HTML::CalendarMonthSimple('month'=>$mm,'year'=>$yyyy);
612                                    $cal->border(2);
613                                    ($l_yyyy,$l_mm) = ($yyyy,$mm);
614                            }
615                            $cal->setcontent($dd, qq{
616                                    <a href="/?date=$row->{date}">$row->{nr}</a>
617                            });
618                    }
619                    $html .= $cal->as_HTML() if ($cal);
620    
621            } else {
622                    $html .= join("</p><p>",
623                          get_from_log(                          get_from_log(
624                                  limit => $q->param('limit') || 100,                                  limit => $q->param('last') || $q->param('date') ? undef : 100,
625                                  search => $q->param('search') || $q->param('grep') || undef,                                  search => $search || undef,
626                                    tag => $q->param('tag') || undef,
627                                    date => $q->param('date') || undef,
628                                  fmt => {                                  fmt => {
629                                            date => sub {
630                                                    my $date = shift || return;
631                                                    qq{<hr/><div class="date"><a href="/?date=$date">$date</a></div> '};
632                                            },
633                                          time => '<span class="time">%s</span> ',                                          time => '<span class="time">%s</span> ',
634                                          time_channel => '<span class="channel">%s %s</span> ',                                          time_channel => '<span class="channel">%s %s</span> ',
635                                          nick => '<span class="nick">%s:</span> ',                                          nick => '%s:&nbsp;',
636                                            me_nick => '***%s&nbsp;',
637                                          message => '<span class="message">%s</span>',                                          message => '<span class="message">%s</span>',
638                                  },                                  },
639                                  message_filter => sub {                                  filter => {
640                                          my $m = shift || return;                                          message => sub {
641                                          $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;                                                  my $m = shift || return;
642                                          return $m;                                                  $m =~ s/($escape_re)/$escape{$1}/gs;
643                                                    $m =~ s#($RE{URI}{HTTP})#<a href="$1">$1</a>#gs;
644                                                    $m =~ s#$tag_regex#<a href="?tag=$1" class="tag">$1</a>#g;
645                                                    return $m;
646                                            },
647                                            nick => sub {
648                                                    my $n = shift || return;
649                                                    if (! $nick_enumerator{$n})  {
650                                                            my $max = scalar keys %nick_enumerator;
651                                                            $nick_enumerator{$n} = $max + 1;
652                                                    }
653                                                    return '<span class="nick col-' .
654                                                            ( $nick_enumerator{$n} % $max_color ) .
655                                                            '">' . $n . '</span>';
656                                            },
657                                  },                                  },
658                          )                          )
659                  ) .                  );
660                  qq{</p></body></html>}          }
661          );  
662            $html .= qq{</p>
663            <hr/>
664            <p>See <a href="/history">history</a> of all messages.</p>
665            </body></html>};
666    
667            $response->content( $html );
668          return RC_OK;          return RC_OK;
669  }  }
670    

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

  ViewVC Help
Powered by ViewVC 1.1.26