/[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 5 by dpavlin, Mon Feb 27 12:10: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 $HOSTNAME = `hostname`;
22    
23  my $NICK = 'irc-logger';  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 => 'logger: ask dpavlin@rot13.org'     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';
43    my $TIMESTAMP = '%Y-%m-%d %H:%M:%S';
44    
45  ## END CONFIG  ## END CONFIG
46    
47    
48    
49  use POE qw(Component::IRC Wheel::FollowTail);  use POE qw(Component::IRC Wheel::FollowTail Component::Server::HTTP);
50    use HTTP::Status;
51  use DBI;  use DBI;
52    use Encode qw/from_to is_utf8/;
53    use Regexp::Common qw /URI/;
54    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 61  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
95    
96     my @messages = get_from_log(
97            limit => 42,
98            search => '%what to stuff in ilike%',
99            fmt => {
100                    time => '{%s} ',
101                    time_channel => '{%s %s} ',
102                    nick => '%s: ',
103                    me_nick => '***%s ',
104                    message => '%s',
105            },
106            filter => {
107                    message => sub {
108                            # 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
121    
122    sub get_from_log {
123            my $args = {@_};
124    
125            $args->{limit} ||= 10;
126    
127            $args->{fmt} ||= {
128                    date => '[%s] ',
129                    time => '{%s} ',
130                    time_channel => '{%s %s} ',
131                    nick => '%s: ',
132                    me_nick => '***%s ',
133                    message => '%s',
134            };
135    
136            my $sql_message = qq{
137                    select
138                            time::date as date,
139                            time::time as time,
140                            channel,
141                            me,
142                            nick,
143                            message
144                    from log
145            };
146    
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";
160            $sql .= " limit " . $args->{limit};
161    
162            my $sth = $dbh->prepare( $sql );
163            if (my $search = $args->{search}) {
164                    $search =~ s/^\s+//;
165                    $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 {
172                    $sth->execute();
173            }
174            my $last_row = {
175                    date => '',
176                    time => '',
177                    channel => '',
178                    nick => '',
179            };
180    
181            my @rows;
182    
183            while (my $row = $sth->fetchrow_hashref) {
184                    unshift @rows, $row;
185            }
186    
187            my @msgs = (
188                    "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) {
216    
217                    $row->{time} =~ s#\.\d+##;
218    
219                    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}) {
225                            $msg .= sprintf($args->{fmt}->{time_channel}, $t, $row->{channel});
226                    } else {
227                            $msg .= sprintf($args->{fmt}->{time}, $t);
228                    }
229    
230                    my $append = 1;
231    
232                    my $nick = $row->{nick};
233                    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;
246                    }
247    
248                    $args->{fmt}->{message} ||= '%s';
249                    if (ref($args->{filter}->{message}) eq 'CODE') {
250                            $msg .= sprintf($args->{fmt}->{message},
251                                    $args->{filter}->{message}->(
252                                            $row->{message}
253                                    )
254                            );
255                    } else {
256                            $msg .= sprintf($args->{fmt}->{message}, $row->{message});
257                    }
258    
259                    if ($append && @msgs) {
260                            $msgs[$#msgs] .= " " . $msg;
261                    } else {
262                            push @msgs, $msg;
263                    }
264    
265                    $last_row = $row;
266            }
267    
268            return @msgs;
269    }
270    
271    
272  my $SKIPPING = 0;               # if skipping, how many we've done  my $SKIPPING = 0;               # if skipping, how many we've done
273  my $SEND_QUEUE;                 # cache  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);
281      },      },
282      irc_255 => sub {            # server is done blabbing      irc_255 => sub {    # server is done blabbing
283        $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);                  $_[KERNEL]->post($IRC_ALIAS => join => $CHANNEL);
284        $_[KERNEL]->post($IRC_ALIAS => join => '#logger');                  $_[KERNEL]->post($IRC_ALIAS => join => '#logger');
285        $_[KERNEL]->yield("heartbeat"); # start heartbeat                  $_[KERNEL]->yield("heartbeat"); # start heartbeat
286  #      $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;  #               $_[KERNEL]->yield("my_add", $_) for keys %FOLLOWS;
287                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
288      },      },
289      irc_public => sub {      irc_public => sub {
290            my $kernel = $_[KERNEL];                  my $kernel = $_[KERNEL];
291            my $nick = (split /!/, $_[ARG0])[0];                  my $nick = (split /!/, $_[ARG0])[0];
292            my $channel = $_[ARG1]->[0];                  my $channel = $_[ARG1]->[0];
293            my $msg = $_[ARG2];                  my $msg = $_[ARG2];
294    
295            print "$channel: <$nick> $msg\n";                  from_to($msg, 'UTF-8', $ENCODING);
296            $sth->execute($channel, $nick, $msg);  
297      },                  print "$channel: <$nick> $msg\n";
298      (map                  $sth->execute($channel, 0, $nick, $msg);
299       {                  add_tag( id => $dbh->last_insert_id(undef,undef,"log",undef),
300         ;"irc_$_" => sub { }}                          message => $msg);
301       qw(join      },
302          ctcp_version      irc_ctcp_action => sub {
303          connected snotice ctcp_action ping notice mode part quit                  my $kernel = $_[KERNEL];
304          001 002 003 004 005                  my $nick = (split /!/, $_[ARG0])[0];
305          250 251 252 253 254 265 266                  my $channel = $_[ARG1]->[0];
306          332 333 353 366 372 375 376                  my $msg = $_[ARG2];
307                  477  
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 {
316                    my $kernel = $_[KERNEL];
317                    my $nick = (split /!/, $_[ARG0])[0];
318                    my $msg = $_[ARG2];
319                    from_to($msg, 'UTF-8', $ENCODING);
320    
321                    my $res = "unknown command '$msg', try /msg $NICK help!";
322                    my @out;
323    
324                    print "<< $msg\n";
325    
326                    if ($msg =~ m/^help/i) {
327    
328                            $res = "usage: /msg $NICK comand | commands: stat - user/message stat | last - show backtrace | grep foobar - find foobar";
329    
330                    } elsif ($msg =~ m/^msg\s+(\S+)\s+(.*)$/i) {
331    
332                            print ">> /msg $1 $2\n";
333                            $_[KERNEL]->post( $IRC_ALIAS => privmsg => $1, $2 );
334                            $res = '';
335    
336                    } elsif ($msg =~ m/^stat.*?\s*(\d*)/i) {
337    
338                            my $nr = $1 || 10;
339    
340                            my $sth = $dbh->prepare(qq{
341                                    select nick,count(*) from log group by nick order by count desc limit $nr
342                            });
343                            $sth->execute();
344                            $res = "Top $nr users: ";
345                            my @users;
346                            while (my $row = $sth->fetchrow_hashref) {
347                                    push @users,$row->{nick} . ': ' . $row->{count};
348                            }
349                            $res .= join(" | ", @users);
350                    } elsif ($msg =~ m/^last.*?\s*(\d*)/i) {
351    
352                            foreach my $res (get_from_log( limit => $1 )) {
353                                    print "last: $res\n";
354                                    from_to($res, $ENCODING, 'UTF-8');
355                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
356                            }
357    
358                            $res = '';
359    
360                    } elsif ($msg =~ m/^(search|grep)\s+(.*)\s*$/i) {
361    
362                            my $what = $2;
363    
364                            foreach my $res (get_from_log(
365                                            limit => 20,
366                                            search => $what,
367                                    )) {
368                                    print "search [$what]: $res\n";
369                                    from_to($res, $ENCODING, 'UTF-8');
370                                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
371                            }
372    
373                            $res = '';
374    
375                    }
376    
377                    if ($res) {
378                            print ">> [$nick] $res\n";
379                            from_to($res, $ENCODING, 'UTF-8');
380                            $_[KERNEL]->post( $IRC_ALIAS => privmsg => $nick, $res );
381                    }
382    
383            },
384            irc_477 => sub {
385                    print "# irc_477: ",$_[ARG1], "\n";
386                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
387            },
388            irc_505 => sub {
389                    print "# irc_505: ",$_[ARG1], "\n";
390                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "register $NICK" );
391    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set hide email on" );
392    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "set email dpavlin\@rot13.org" );
393            },
394            irc_registered => sub {
395                    warn "## indetify $NICK\n";
396                    $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
397            },
398    #       irc_433 => sub {
399    #               print "# irc_433: ",$_[ARG1], "\n";
400    #               warn "## indetify $NICK\n";
401    #               $_[KERNEL]->post( $IRC_ALIAS => privmsg => 'nickserv', "IDENTIFY $NICK" );
402    #       },
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 180  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
523    
524    my $httpd = POE::Component::Server::HTTP->new(
525            Port => $NICK =~ m/-dev/ ? 8001 : 8000,
526            ContentHandler => { '/' => \&root_handler },
527            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_';
534    p { margin: 0; padding: 0.1em; }
535    .time, .channel { color: #808080; font-size: 60%; }
536    .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%; }
539    .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_
548    
549    my $max_color = 4;
550    
551    my %nick_enumerator;
552    
553    sub root_handler {
554            my ($request, $response) = @_;
555            $response->code(RC_OK);
556            $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(
571                    qq{<html><head><title>$NICK</title><style type="text/css">$style} .
572                    $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">
577                    <input type="submit" value="search">
578                    </form>
579                    } .
580                    $cloud->html(500) .
581                    qq{<p>} .
582                    join("</p><p>",
583                            get_from_log(
584                                    limit => $q->param('last') || 100,
585                                    search => $search || undef,
586                                    tag => $q->param('tag') || undef,
587                                    fmt => {
588                                            date => '<hr size="1" style="clear: both;"/><div class="date">%s</div> ',
589                                            time => '<span class="time">%s</span> ',
590                                            time_channel => '<span class="channel">%s %s</span> ',
591                                            nick => '%s:&nbsp;',
592                                            me_nick => '***%s&nbsp;',
593                                            message => '<span class="message">%s</span>',
594                                    },
595                                    filter => {
596                                            message => sub {
597                                                    my $m = shift || return;
598                                                    $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                    ) .
616                    qq{</p></body></html>}
617            );
618            return RC_OK;
619    }
620    
621  POE::Kernel->run;  POE::Kernel->run;
Legend:
Removed from v.5  
changed lines
  Added in v.34
  ViewVC Help
Powered by ViewVC 1.1.26